#! /usr/local/bin/perl 
#######################################################################
# This software has been created by Genome Research Limited (GRL).    # 
# GRL hereby grants permission to use, copy, modify and distribute    # 
# this software and its documentation for non-commercial purposes     # 
# without fee at the user's own risk on the basis set out below.      #
# GRL neither undertakes nor accepts any duty whether contractual or  # 
# otherwise in connection with the software, its use or the use of    # 
# any derivative, and makes no representations or warranties, express #
# or implied, concerning the software, its suitability, fitness for   #
# a particular purpose or non-infringement.                           #
# In no event shall the authors of the software or GRL be responsible # 
# or liable for any loss or damage whatsoever arising in any way      # 
# directly or indirectly out of the use of this software or its       # 
# derivatives, even if advised of the possibility of such damage.     #
# Our software can be freely distributed under the conditions set out # 
# above, and must contain this copyright notice.                      #
#######################################################################

# $Id: owl_printmap.pm,v 1.9 1998/09/23 08:43:04 dn1 Exp $
# $Log: owl_printmap.pm,v $
# Revision 1.9  1998/09/23  08:43:04  dn1
# *** empty log message ***
#
# Revision 1.8  1998/08/25  08:49:35  dn1
# *** empty log message ***
#
# Revision 1.7  1998/08/24  14:21:20  dn1
# *** empty log message ***
#
# Revision 1.6  1998/08/24  14:07:27  dn1
# *** empty log message ***
#
# Revision 1.5  1998/08/24  12:45:34  dn1
# fixed-bug;
# my $Last;
#
# Revision 1.4  1998/08/17  14:15:54  dn1
# T33 format plates now handled as well :-)
#
# Revision 1.3  1998/07/08  16:25:50  dn1
# if ($get_from ne ''){
# 	    print OUTPUT "$plate      :from $get_from\n";
# 	} else {
# 	    print OUTPUT "$plate      :cannot determine original project\n";
# 	}
#
# Revision 1.2  1998/07/08  16:18:32  dn1
# #printf OUTPUT  "%d %d (MAP $map$comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;
# replaced with...
# printf OUTPUT  "%d %d (MAP_ID is $map   MAP_TYPE is $comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;
#
# Revision 1.1  1998/06/24  10:16:00  dn1
# Initial revision
#

require Exporter;

use DBI;

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

#use Data::Dumper;

package owl_printmap;

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

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


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

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

    # Bug fixing
    @all_plates = ();
    $this_plate = 'Some plate';
    $old_plate = 'Some other plate';


    # What is the current date/time ?
    my $date = sprintf("%04d-%02d-%02d-%02d%02d%02d",((localtime)[5]+1900),((localtime)[4]+1),((localtime)[3]),((localtime)[2]),((localtime)[1]),((localtime)[0]));


    foreach $this (@printmap_struct){
	################################
        # Choices for output; $outfile #
        ################################
	if ($outfile eq 'Screen') {
	    open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
	} elsif ($outfile eq 'None'){
	    open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
	    warn "$prog: Spooling to printer: \"$printer\"\n";
	} else {
	    open(OUTPUT,">$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
	}
	&init();
	&pre();
	############################################
	&printmap($this, $each, @printmap_struct);
	
	&post();
	close(OUTPUT);
    
	###############################################
        # Also have to print the orders out for a map #
        ###############################################
	################################
        # Choices for output; $outfile #
        ################################
	if ($outfile eq 'Screen') {
	    open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
	} elsif ($outfile eq 'None'){
	    open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
	    warn "$prog: Spooling to printer: \"$printer\"\n";
	} else {
	    open(OUTPUT,">$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
	}

	&dumporders($dbh, $S_description_list, $date, $this, @printmap_struct);

	close(OUTPUT);
    }

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

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

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

	# YUCK ! a call to equus !
	my $peek = `peek plate $plate`;
	my ($get_from) = $peek =~ /Clone\s+(.*)/;
	$get_from =~ s/\"//g;
	##############################################
	#printf STDERR "$plate      :from $get_from\n";
	if ($get_from ne ''){
	    print OUTPUT "$plate      :from $get_from\n";
	} else {
	    print OUTPUT "$plate      :cannot determine original project\n";
	}
	##############################################

    }

    close(OUTPUT);
    
    $dbh->disconnect;


}				# end of sub printmaps_out {


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

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

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

    

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

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

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

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

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

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

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

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

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





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

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

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

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

	if ($this_project ne $old_project){

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


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

	$old_project = $this_project;

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

    }
}    # end of dumporders


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

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

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

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

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

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

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

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

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

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

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

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


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

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


	    print OUTPUT "\nshowpage\n";
	}
    }
    

}



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

    local($date);

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

}


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

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


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

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

    print OUTPUT "gr\n";

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

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


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


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

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


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



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

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

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

    $xfrom = $numfrom % $columns;
    $yfrom = int($numfrom / $columns);
    $xto = $numto % $columns;
    $yto = int($numto / $columns);

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

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

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

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


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

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

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

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



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

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

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


}

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

    print OUTPUT "%%Trailer\n";

}




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

sub init {
    local($format);

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

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

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

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

}




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

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

}


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

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

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

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

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

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

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

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

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

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

    #jiggery pokery



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










