#!/usr/local/bin/perl -w

#############################################
# Sequence Annotation-Directed PCR Primer   #
# Design:                                   #
# This program processes requests for       #
# PCR primer design using the AnyPrimer     #
# APIs for primer3 and e-PCR                #
# DNA sequences and annotations are from    #
# from GenBank files (stored locally) of    #
# completed genomes.                        #
#                                           #
# April,2003.                               #
# Kim Wong kwong@bcgsc.bc.ca                #
# Sheldon McKay smckay@bcgsc.bc.ca          #
#############################################

########################################
# SPECIFY LOCATION OF GENOME FILES AND #
# AnyPrimer LIBRARIES                  #
########################################
#
# species root directory
my $root      = '/home/smckay/release/species/';

# path to AnyPrimer libraries (if not in
# standard location)
# use lib "/home/user/modules";

########################################

use CGI ':standard';
use CGI::Carp 'fatalsToBrowser';
use AnyPrimer;
use AnyPrimer::Tables;

use strict qw/vars subs/;

my $script = "genome_primer";

my $page = AnyPrimer::Tables->new or die "No table object";

$| = 1;

frontpage() unless param;


my $species;
my $gene_template;

if ( param('gene') || param('species') ) {
   $species = param('species');
   if ($species =~ /Select/) { 
     killme("Species not specified"); 
   }
   $gene_template = param('gene');
   if ($gene_template =~ /^\s*$/) {
     killme("No gene name specified");
   }

}

else  { exit; }
#######################
# Process the options #
#######################

my $checkgene         = param('check')       || '';
my $product_size      = param('size')        || 1000;
my $size_range        = param('range')       || 200;
my $word_size         = param('word')        || 7;
my $allowed_mismatch  = param('mismatch')    || 2;
my $opt_tm            = param('tm')          || 60;
my $tm_range          = param('tmrange')     || 2;
my $high_qual         = param('qual')        || 1;
my $sets              = param('sets')        || 10;
my $opt_primersize    = param('psize')       || 20;
my $psize_range       = param('psizerange')  || 2;
my $internal_primers  = param('nested')      || '';
my $neighbor_ok       = param('neighbor')    || '';
my $nested            = param('nested_sets') || '';
my $nested_pair       = param('pair_with')   || '';
my $clamp             = param('clamp')       || '';
my $target_start      = param('targetstart') || '';
my $target_end        = param('targetend')   || '';

$nested_pair = '' if $nested_pair =~ /none/i;


#########################
# Get the sequence info #
#########################

$root          = $root . $species;  
my @gff        = `zcat $root\/*gff.gz |grep -iw 'gene "*$gene_template"*'`;
#print join "<br>", @gff;
my $gff        = $gff[0];
my ($source)   = $gff =~ /^(\S+)/;
my $source_dna = '';
my $dna        = dna($source);
my $epcrdb     = $dna;
my @genes      = `cat $root\/$species.genes` or die "No gene list";
my $notfound   = "$species genes are listed below:<br>" . join "<br>", @genes;
my %gene_info  = ();

$gene_info{' Source DNA'} = $source_dna; 

#
# Check source dna: linear or circular
#
my $linear_dna;
if ($source_dna =~ /linear/i) {
  $linear_dna = 1;
}

# maybe lose this
my $msg  = sanity_check('options') || '';

killme("Gene $gene_template not found", $notfound)
  unless $gff && $gff =~ /\b$gene_template\b/i;

if (scalar @gff > 1) { 
  print "More than one entry found for this gene, ",
         "using the first one.\n" 
}

#####################################
# Process gene information and find #
# target gene neighbors             #
#####################################


$gene_info{$1} = $2 while $gff =~ /(\S+)\s+("?.+?"?)\s+;/g;

delete $gene_info{'SEQ'};
delete $gene_info{'translation'};

$gene_info{$_} =~ s/"//g for keys %gene_info;
$gene_info{'db_xref'} =~ s/\s+/, /g if $gene_info{'db_xref'};

if ($nested_pair) {
  $msg .= "Nested internal primers are paired with the ".
          "external $nested_pair primer\n";
}
else {
  $msg .= "Left and right nested primers are paired with each other\n"
    unless !$internal_primers;
}


#
# Save gene name and coordinates from 
# the correct source DNA; find target 
# and neighbor coordinates
#
my %map;
for (@genes) {
  my @coords     = split /\s+/, $_;
  my $genome     = shift @coords;
  if ($genome =~ /\b$source\b/) {   
    my $gene       = shift @coords;
    $gene_template = $gene if $gene  =~ /\b$gene_template\b/i;
    $map{$gene}    = \@coords;
  }  
}

#
# Save target gene stats
#
my ($genestart, $geneend, $genestrand) = @{$map{$gene_template}};
my $genelength = $geneend - $genestart + 1;

$gene_info{'length'}      = "$genelength bp";
$gene_info{'coordinates'} = "$genestart..$geneend";
$gene_info{'strand'}      = $genestrand;

$msg .= "$gene_template is on the - strand; note that primers ".
        "are oriented on the + strand\n" if $genestrand eq '-';
	
#
# Find neighbors
#
my $left_dist      = 100000000;
my $right_dist     = 100000000;
my $left_neighbor  = '';
my $right_neighbor = '';

my @sorted_genes= sort by_start keys %map;
for (@sorted_genes) {
  my $start      = $map{$_}->[0]; 
  my $stop       = $map{$_}->[1];
  if ($start < $genestart) { 
     $left_neighbor = $_;
     $left_dist     = $genestart - $stop;
  }
  elsif ($start > $genestart) { 
     $right_neighbor = $_;
     $right_dist     = $start - $geneend;
     last;
  }

}

my $first_gene = shift @sorted_genes;
my $last_gene  = pop @sorted_genes;
my $dna_length = length $dna;

#
# Re-map coordinates for first/last genes
#
my $remap_right = 0;

unless ($linear_dna) {
  if ($gene_template eq $first_gene || $gene_template eq $last_gene) {
    unless ($left_neighbor) {
       $left_neighbor = $last_gene;
       $left_dist     = $dna_length - $map{$left_neighbor}->[1] + $genestart - 1;
       $map{$left_neighbor}->[0]  = - remap($dna_length,$map{$left_neighbor}->[0]) - 1;
       $map{$left_neighbor}->[1]  = - remap($dna_length,$map{$left_neighbor}->[1]) - 1;
    }
    unless ($right_neighbor) {
       $right_neighbor = $first_gene;
       $right_dist     = $map{$right_neighbor}->[0] + $dna_length - $geneend - 1;
       $map{$gene_template}->[0] = - remap($dna_length,$map{$gene_template}->[0]) - 1;
       $map{$gene_template}->[1] = - remap($dna_length,$map{$gene_template}->[1]) - 1;
       $map{$left_neighbor}->[0] = - remap($dna_length,$map{$left_neighbor}->[0]) - 1;
       $map{$left_neighbor}->[1] = - remap($dna_length,$map{$left_neighbor}->[1]) - 1;
       $remap_right = 1;
    }
  }
}

#
# Calculate total sequence plus surrounding DNA
# to be used for primer design
#
my $pad = 5000;
my $right_end = 5000;

# for really small plasmids
if ($dna_length < 15000) {
  $pad = ($product_size + $size_range)/2;
  $right_end = $pad;

}

if ($genestart < $pad && $linear_dna)  {
   $pad = $genestart;
}  
elsif (($dna_length - $geneend) < $right_end && $linear_dna) { 
     $right_end = $dna_length - $geneend;
}  
elsif ($genestart < $pad && $gene_template ne $first_gene) {
     $pad = $genestart;
}


my $offset     = $genestart - $pad;
my $seq_length = $genelength + $pad + $right_end;



##########################################
# Get the template dna for primer design #
##########################################

#
# Add sequence to beginning or end if necessary
#
my $add_leftdna;
my $add_rightdna;

unless ($linear_dna) {
  if ($offset < 0) { 
    $add_leftdna = substr $dna, $offset;
    $dna = $add_leftdna . $dna;
    $genestart = $genestart + abs $offset;
    $geneend   = $geneend + abs $offset;
    $offset = 0;
  }
  elsif ($dna_length - $geneend < $right_end) {
    my $add_rlength = $right_end - ($dna_length - $geneend); 
    $add_rightdna = substr $dna, 0, $add_rlength;
    $dna = $dna . $add_rightdna;
  }
}

my $targetsequence = substr $dna, $offset, $seq_length;
my $length = length $targetsequence;

#
# Save feature annotations of target and 
# neighbors for rendering
#
my $genes = '';

for ($gene_template, $left_neighbor, $right_neighbor) {
  next if /^$/;
  my %params = (type   => 'gene',
                label  => $_,
		start  => $map{$_}->[0],
		stop   => $map{$_}->[1],
		strand => $map{$_}->[2],
		desc   => ' ');
  $params{'desc'} = "target gene" if $_ eq $gene_template;
  $genes .= feat(%params);
}

#################################
# Render the gene map URL       #
# and print summary if checking #
#################################

my $genemap='';

if ($gene_template eq $last_gene && $linear_dna) {
     $genemap = $page -> render(start => ($map{$gene_template}->[0] - 1000),
                                stop  => $dna_length,
			        feat  => $genes
			 );     
}
else {
     $genemap = $page -> render(start => ($map{$gene_template}->[0] - 1000),
                                stop  => ($map{$gene_template}->[1] + 1000),
		                feat  => $genes
                       );
}
   

summary('check') if $checkgene;


###################################
# Map target and excluded regions #
###################################


my $excluded = '';

#
# Target the user-defined region or else the middle of the gene
#
my $target = '';

if ($target_start) { 
  die "Both start and end points are required for the target region"
     unless $target_end;
  unless ($target_start < $geneend && $target_start > $genestart) {
    killme("Target region is not within gene $gene_template");
  }
  if ($offset == 0) {
     $target_start += length $add_leftdna;
     $target_end += length $add_leftdna;
  }
  else {
    $target_start -= $offset;
    $target_end   -= $offset;
  }
  my $target_length = $target_end - $target_start;
  $target = $target_start . ",$target_length"; 

}
else {
  $target  = $genestart - $offset + int(($geneend - $genestart)/2);
  $target    .= ",1";
}


#
# If asked, don't put primers in neighboring genes
#
unless ($neighbor_ok) {
  $excluded  .= " 1," . ($genestart - $left_dist - $offset) if $left_neighbor;
  
  my $r       = $geneend + $right_dist - $offset;
  $excluded  .= " $r," . ($length - $r) if $right_neighbor;
  $msg       .= "Primers not allowed in neighboring genes\n";
  
  my $safe_zone = $geneend + $right_dist -
                  ($genestart - $left_dist) -
		  $size_range  if $left_neighbor && $right_neighbor;
  
  if ($safe_zone && $product_size > $safe_zone) {
      $product_size = $safe_zone;
      $msg .="PCR product size reduced to $product_size +/- $size_range " .
             "to avoid nearby genes\n";
  }
  
  $excluded  .= " ";
} 
else {
  $msg .= "Primers allowed in neighboring genes\n";
}

#
# Centre the PCR product by excluding the middle of the gene 
#
unless ($target_start) {
  my $exclude_mid;
  my $rwindow;
  my $lwindow;
  my $diff;
  #
  # Maximize excluded region      
  #
  
  # Linear DNA and close to 5' end
  if ($linear_dna && $genestart < 75)  {
      $diff = 75 - $genestart;
      $lwindow = int($genelength/2 - $diff);
      if ($right_dist < 50 && !$neighbor_ok) {
         $diff = 50 - $right_dist;
	 $rwindow = int($genelength/2 - $diff);
      } 
      else {
         $rwindow = int($genelength/2 - 0.1*$genelength);
      }
  }
  # Linear DNA and close to 3' end
  elsif ($linear_dna && ($dna_length - $geneend) < 75) {
      $diff = 75 - ($dna_length - $geneend);
      $rwindow = int($genelength/2 - $diff);
      if ($left_dist < 50 && !$neighbor_ok) {
         $diff = 50 - $left_dist;
	 $lwindow = int($genelength/2 - $diff);
      }
      else {
         $lwindow = int($genelength/2 - 0.1*$genelength);
      }
  }
  # Primers not allowed in neighbors and large product size
  elsif (!$neighbor_ok && $genelength < $product_size) {
      $rwindow = int($genelength/2 - 0.1*$genelength);
      $lwindow = $rwindow;
      my $check_ends = int($genelength/2 - $rwindow);
      if ($check_ends < 50) {
          if ($left_neighbor && $left_dist < 50) {
	      $diff = 50 - $left_dist;
	      $lwindow = int($genelength/2 - $diff);
	  } 
	  if ($right_neighbor && $right_dist < 50) {
              $diff = 50 - $right_dist;
	      $rwindow = int($genelength/2 - $diff);
	  }
       }
  }
  else {
     $rwindow = int($product_size/2 - 0.1*$genelength);
     $lwindow = $rwindow;
  }
  
  $exclude_mid = $` if $target =~ /,.+/;
  
  # If neighbors are overlapping target gene
  if ($right_dist < 0 || $left_dist < 0) {
     if ($right_dist < 0) {
        $rwindow = int($rwindow + $right_dist - 50);
     }
     if ($left_dist < 0) {
        $lwindow = int($lwindow + $left_dist - 50);
     }
  }
  
  $excluded .= ($exclude_mid - $lwindow). "," .($lwindow + $rwindow);
}

##################
# Design primers #
##################

my $primer   = AnyPrimer->new( method =>  'local',
                               program => 'primer3'
			     ) or die AnyPrimer->error;

my $prodsize = ($product_size - $size_range).
               "-" .($product_size + $size_range);

#
# Core input options for primer3
#
my %eparams=(id        =>$gene_template,
             seq       =>$targetsequence,
             sizerange =>$prodsize,
             num       =>$sets,
             mintm     =>($opt_tm - $tm_range),
             maxtm     =>($opt_tm + $tm_range),
             minpsize  =>($opt_primersize - $psize_range),
             maxpsize  =>($opt_primersize + $psize_range),
           );

#
# other input options
#
$eparams{'excluded'} = $excluded if $excluded;
$eparams{'target'}   = $target if $target;
$eparams{'gcclamp'}  = $clamp if $clamp;


my $result = $primer->design( %eparams ) or die $primer->error;

#
# Make nested primers if requested
#
my %nested;
if ($nested && $internal_primers) {
  for my $pair (1..$sets) {
    for (1..$nested) {
      $nested{$pair}{$_} = nested_primers($pair, $_, $nested_pair);
    }
  }
}


#
# Re-map coordinates for mapping if necessary
#
if ($offset == 0 ) {
  $genestart = $genestart - length $add_leftdna;
  $geneend  = $geneend - length $add_leftdna;

}

if ($remap_right) {
  $genestart = $map{$gene_template}->[0];
  $geneend = $map{$gene_template}->[1]; 
}
#
# Output the results
#

my $output = summary();
$output =~ s/\<.+?\>//gm;
$output =~ s/^\s*$|&nbsp;//gm;
#notify( $output );

print end_html;
 
################################ END #################################

sub summary {
    my $command = shift;
    my $content = '';
    my $epcr   = AnyPrimer->new( program => 'epcr',
                                 method  => 'local'
  	         	       ) or die AnyPrimer->error;
			      
    print header;
    print start_html(-title   => 'Primer Design results',
                     -bgcolor => 'whitesmoke'), "<center>";
  
    $gene_info{'image'} = $genemap;
    $msg =~ s/^.+/<li>$&/gm;
    $msg =~ s/\n/<br>/gm;
    $gene_info{'other'} = $msg;
    
    # 
    # Indicate up/downstream or overlapping neighbors
    #
        if ($left_neighbor) {
            if ($left_dist < 0) { 
	        $left_neighbor  .= ", " . -$left_dist . " bp overlap<br>";
	    } else {
                $left_neighbor  .= ", $left_dist bp upstream<br>";
	    }
	}
	if ($right_neighbor) {
	    if ($right_dist < 0) {
	        $right_neighbor .= ", " . -$right_dist . " bp overlap";
            } else {
                $right_neighbor .= ", $right_dist bp downstream";
	    }
	}
	$gene_info{'nearby_genes'} = $left_neighbor . $right_neighbor;
  
    print $page->info_table( $gene_template, %gene_info);
    print end_html and exit if $command eq 'check';
    
    print br, $page->PCR_header or die $page->error;
    $content = $page->PCR_header;
    
    for (1 .. $sets) {
        my $primers    = '';
        my %result     = %$result;
        my $startleft  = $result{$_}{'startleft'} + $offset - length $add_leftdna;
        my $startright = $result{$_}{'startright'} + $offset - length $add_leftdna;
        my $product    = $result{$_}{'prod'};
	my $qual       = $result{$_}{'qual'};
    
        my $epcr_result = $epcr->run( left      => $result{$_}{'left'},
	                              right     => $result{$_}{'right'},
				      word_size => $word_size,
				      mismatch  => $allowed_mismatch,
				      prod_size => $result{$_}{'prod'},
				      seq       => $dna,
				      permute   => 1
				    ) or die $epcr->error;
	
	$result{$_}{'qual'} = "<font color='red'>$qual</font>"
          if $qual > $high_qual;        
	#
	# Re-map coordinates for output
	# 
        $result{$_}{'startleft'} += ($offset - length $add_leftdna);
	$result{$_}{'startright'} += ($offset - length $add_leftdna);
	if ($remap_right) {
           $result{$_}{'startleft'} = - ($dna_length - $result{$_}{'startleft'});
	   $result{$_}{'startright'} = remap2($dna_length,$result{$_}{'startright'});
	}
	
	print $page->PCR_set($_) or die $page->error;
        $content .= $page->PCR_set($_); 
	
        #
	# Save the feature info
	#
	
	my $pcr_startleft = $startleft;
        
	# Re-map coordinates
	if ($remap_right) {
           $startleft = - ($dna_length - $startleft) - 1;
	   $startright = remap2($dna_length,$startright); 
	}
        
	$primers .= save('F', $startleft);
        $primers .= save('R', $startright); 
    
        my $label = $nested ? 'External' : ' ';
    
        my $local = \%result;
        print $page->PCR_row( primers => $local,
                               setnum  => $_,
	    		       label   => $label
	  		     ) or die $page->error;
        
        $label = i($species) . " genome";
	print $page->ePCR_row( $epcr_result, $label );
	
	#
	# Check nested products
	#
	for my $nested_set (1..$nested) {
            my %iresult   = %{$nested{$_}{$nested_set}};
	    my $hideleft  = 1 if $nested_pair eq 'left';
	    my $hideright = 1 if $nested_pair eq 'right';
	    my $iqual     = $iresult{1}{'qual'};

  	    $iresult{1}{'qual'} = "<font color='red'>$iqual</font>"
	      if $iqual > $high_qual;
	    #
	    # Re-map coordinates
	    #
            $iresult{1}{'startleft'} += ($offset - length $add_leftdna);
            $iresult{1}{'startright'} += ($offset - length $add_leftdna);
            if ($remap_right) {
               $iresult{1}{'startleft'} = -remap($dna_length,$iresult{1}{'startleft'}) - 1;
	       $iresult{1}{'startright'} = remap2($dna_length,$iresult{1}{'startright'});
	    }

	
	    my ($istartleft, $istartright) = ();
	    
	    my $amplicon    = substr $dna, ($pcr_startleft), ($product + 2);
            
	    my $epcr_result = $epcr->design( left      => $iresult{1}{'left'},
                                             right     => $iresult{1}{'right'},
                                             word_size => $word_size,
                                             mismatch  => $allowed_mismatch,
                                             seq       => $amplicon
                                           ) or die $epcr->error;

	    
	    if (!$hideleft && !$hideright) {
	        $istartleft  = $iresult{1}{'startleft'};
	        $primers .= save('F'.$nested_set, $istartleft);
	        $istartright = $nested{$_}{$nested_set}->startright;
		$primers .= save('R'.$nested_set, $istartright);
	    }
	    elsif ($hideleft) {
	        $istartright = $iresult{1}{'startright'};
	        $primers .= save('R'.$nested_set, $istartright);
                
		for my $key ('tmleft', 'startleft', 'left') {
	  	    delete $iresult{1}{$key};
	        }
	    }
	    else {
	        $istartleft  = $iresult{1}{'startleft'};
	        $primers .= save('F'.$nested_set, $istartleft);
	        
		for my $key ('tmright', 'startright', 'right') {
	            delete $iresult{1}{$key};
	        } 
            }
		
            
            my $out= $page->PCR_row( primers => \%iresult,
                                     label   => "Nested $nested_set",
     		                   ) or die $page->error; 
	    $content .= $out;
	    print $out;
	    
	    my $label = 'External amplicon';
	    print $page->ePCR_row( $epcr_result, $label );
	    $content .= $page->ePCR_row( $epcr_result, $label );
	  }


    my $image = $page->render(start => $startleft  - 100,
                              stop  => $startright + 100,
	                      feat  => $genes . $primers
		       );
		      
    print $page->PCR_map( $image ) or die $page->error;	   
    $content .= $page->PCR_map( $image );
  }
  print "</table>";
  $content .= "</table>";
}

##########################
#Design Internal Primers #
##########################

sub nested_primers {
  my $set    = shift;
  my $layer  = shift;
  my $paired = shift;
  my ($start, $end) = ();
  
  # start and stop depend on unilateral vs bilateral nesting
  # and how many layers deep we are.  Excluded zones grow and
  # product sizes shrink with each round of nesting
  if ($layer > 1) {
    if ($paired eq 'right') {
      $start = $nested{$set}{$layer - 1}->startleft;
      $end   = $result->startright($set);
    } 
    elsif ($paired eq 'left') {
      $start = $result->startleft($set);
      $end   = $nested{$set}{$layer - 1}->startright;
    }
    else {
      $start = $nested{$set}{$layer - 1}->startleft;
      $end   = $nested{$set}{$layer - 1}->startright;
    }
  }
  else {
    $start = $result->startleft($set);
    $end   = $result->startright($set);
  }

  my $ilength   = $end - $start;
  my $amplicon  = substr $targetsequence, $start, $ilength;
  my $factor    = $paired ? 1 : 2;
  my $interval  = $paired ? 10 : 20;
  my $iminsize  = $ilength - ($factor * $internal_primers);
  my $imaxsize  = $ilength - $interval;
  my $iexcluded = '';
  $iexcluded    = "1, " . ($start + 10) unless $paired eq 'left';
  $iexcluded   .= " " . ($end - 10) . "," . ($length - $end + 10)
    unless $paired eq 'right';
  $iexcluded    =~ s/^ //;
  
  my %iparams = (id        => "internal $layer",
                 seq       => $targetsequence,
  	         sizerange => "$iminsize-$imaxsize",
      	         num       => 1,
		 mintm     => ($opt_tm - $tm_range),
		 maxtm     => ($opt_tm + $tm_range),
		 minpsize  => ($opt_primersize - $psize_range),
		 maxpsize  => ($opt_primersize + $psize_range),
		 excluded  => $iexcluded
		);
    		
  $iparams{'leftin'}  = $result->left($set) if $paired eq 'left';
  $iparams{'rightin'} = $result->right($set) if $paired eq 'right';
  $iparams{'gcclamp'} = $clamp if $clamp;
  
  my $done = $primer->design(%iparams) or die $primer->error;

  $done;

}



sub sanity_check {

  my $stage = shift;
  my $warning = '';

  if ($stage eq 'options') {

    if ($opt_primersize < 16 || $opt_primersize > 30) {
    $warning = "<h2>Primer size selected ($opt_primersize)".
               " is outside of optimal size range</h2>\n" 
    }

    if ($opt_primersize > 25) {
      $warning .= "<b>Warning:</b> It is not easy to find ".
                  "a complete set of primers of length > 25 ".
                  "nt.<br>, If you have trouble finding".
                  "primers, try reducing the size<br>"
    }

    
    # is this working?
    $warning .= "<h2>Gene $gene_template was not found</h2>"
      unless grep /$gene_template/i, @genes;
  }


  $warning;
}

#########################################
# Build up a feature file for rendering #
#########################################

sub feat {
  my %feat = @_;
  
  #reverse orientation for - strand features
  
  ($feat{'start'}, $feat{'stop'}) = ($feat{'stop'}, $feat{'start'})
    if $feat{'strand'} eq "-";
    
  my $feat = $feat{'type'};
  $feat   .= "\t'" . $feat{'label'} . "'" if $feat{'label'};
  $feat   .= "\t" . $feat{'start'} . "-" . $feat{'stop'};
  $feat   .= "\t'" . $feat{'desc'} . "'" if $feat{'desc'};
  return $feat . "\n";
}
    
  
sub save {
  my $label = shift;
  my $begin = shift;
  my ($type, $start, $stop) = $label =~ /F/ ?
     ('forward_primer', $begin, ($begin + 20)) :
     ('reverse_primer', ($begin - 20), $begin);

  return feat(type   =>  $type,
              label  =>  $label,
              start  =>  $start,
              stop   =>  $stop,
              desc   =>  ' ')
}

sub killme {
  my $error = shift;
  my $more  = shift;
  print header,
        "<center>", h1("Error: $error"), "</center>",
	$more;
  exit;
}

sub notify {
    my $mail = "smckay\@bcgsc.bc.ca";
    my $content = shift;
    $content = $species . "\n" . $gene_template . "\n" . $content;
    system "echo '$content' |mail -s '$gene_template Anyprimer usage report' $mail";
}

sub dna {
    my $source = shift;
    local $/ = '>';
    my @dna = `cat $root\/$species.fa` or die "No DNA";
    for (@dna) {
        next unless /$source/;
        $source_dna = $1 if ($_ =~ /$source\s+(.+)\n/);
	s/^.+enome|\n//gm;
        s/[^GATCgatc]/n/g;
        return lc $_
    }
}
			    
sub by_start {
  $map{$a}[0] <=> $map{$b}[0]; 
}

sub remap {
  my ($begin, $end) = @_;
  my $diff = abs ($begin - $end);
  return $diff;
}

sub remap2 {
  my ($length, $position) = @_;
  my $result;
  if ($length > $position) {
    $result = -($length - $position + 1);
  } 
  else {
    $result = $position - $length;
  }
  return $result;
}

sub frontpage {
my $jscript=<<END;
function checkGene() {
    var gene = document.f1.gene.value;
    var species = document.f1.species.value;
    if (gene.match(/click/i)) gene = '';
    if (species.match(/select/i)) species = '';

    if (gene && species) {
       window.open('$script?species='+species+';gene='+gene+';check=1',
                   gene, 'width=710,height=500,scrollbars,resizable');
    }
    else {
       alert('Both an gene name and species must be provided');
    }
}



//  Edit this menu to add new species

function exampleGene() {

    // find out which species has been selected
    //
    var selected = document.f1.species.selectedIndex;

    // create an array to store example gene names
    //
    var genes    = new Array(6)

     genes[0]     = 'click here ->';
     genes[1]     = 'DRB0004';
     genes[2]     = 'thrC';
     genes[3]     = 'RP004';
     genes[4]     = 'thrC';
     genes[5]     = 'VC0004';


    document.f1.gene.value = genes[selected];
}

END


print header;

my $label = i("Sequence Annotation-Directed PCR Primer Design");
#my $progress = "UNDER DEVELOPMENT: Please direct comments or questions to";
#my $email = "smckay\@bcgsc.bc.ca";
my $space = "&nbsp;" x 4;
my $font = qq(<font face="Times" size=3>);
my $strand = qq(<font face="MS sans serif" size=2> +/ - </font>);

#
# Edit this menu to add new species
#
my $species =
	['Select a species',
	'Deinococcus_radiodurans',
	'Escherichia_coli_K12',
	'Rickettsia_prowazekii',
	'Salmonella_typhimurium_LT2',
	'Vibrio_cholerae'];


my $speciesMenu = popup_menu( -name     => 'species', 
                              -values   => ($species), 
			      -onchange  =>"exampleGene()"
			    );

my $buttons = table( {-align => 'center'}, 
                     Tr(
		       td([submit,reset]))
		   );

my $table = table({-align=>'center', -border=>0, -cellspacing=>5, -cellpadding=>1,-width=>600},
                 [
                    Tr ({-height=>20},
                         [
                           td({-align=>'center', -bgcolor=>"#3399ff", -width=>"50%"}, $font."Design Parameters").
                           td({-align=>'center', -bgcolor=>"#3399ff"}, $font."Nested Primers"),
                           td($speciesMenu),
			   td(textfield(-name=>'gene', -size=>10, -value=>'Click-->').($font." Gene &nbsp;").
                              button(-name=>'Info',-value=>'Info...',-onclick=>'checkGene(this)')).
                           td($font."Separate nested primers by &nbsp;&nbsp;".
                              textfield(-name=>'nested',-size=>4,-value=>100).$font." bp &nbsp;"),
                           td($font."Design &nbsp;".textfield(-name=>'sets',-size=>2,-value=>5).$font."&nbsp; primer sets").
                           td($font."Pair with &nbsp;".
                              radio_group(-name=>'pair_with',-values=>(['left','right','none']),-default=>'none')),
                           td(textfield(-name=>'size',-size=>5,-value=>1000).$strand.
                              textfield(-name=>'range',-size=>3,-value=>100).$font."&nbsp; PCR product").
                           td($font."Design ".textfield(-name=>'nested_sets',-size=>3, -value=>1).$font." nested pairs"),
                           td(textfield(-name=>'psize',-size=>4,-value=>20).$strand.
                              textfield(-name=>"psizerange",-size=>2,-value=>2).$font.("&nbsp; Primer size")).
                           td({-align=>'center',-bgcolor=>"#3399ff"},$font."Target Region (optional)"),
                           td(textfield(-name=>'tm',-size=>4,-value=>60).$strand.
                              textfield(-name=>"tmrange",-size=>2,-value=>5).$font."&nbsp; Optimum Tm").
                           td(textfield(-name=>"targetstart",-size=>5).$font."&nbsp; to &nbsp;".
                              textfield(-name=>"targetend",-size=>5).$font."&nbsp; Coordinates"),
                           td(textfield(-name=>"clamp",-size=>3).$font."&nbsp; CG clamp").
                           td({-align=>'center',-bgcolor=>"#3399ff"},$font."e-PCR Options"),
                           td(textfield(-name=>"qual",-size=>3,-value=>'1.0').$font."&nbsp; Max. Q value").
                           td(textfield(-name=>"word",-size=>2,-value=>7).$font."&nbsp; Word size"),
                           td(checkbox(-name=>"neighbor", -value=>'yes', -label=>'',-checked=>"checked").
                              $font."&nbsp;Allow primers in nearby genes").
                           td(textfield(-name=>"mismatch",-size=>1,-value=>2).$font."&nbsp; Allowed mismatches"),
                           td({-align=>'center',-colspan=>2,-height=>50},$buttons),
                         ]
                     )
                 ]
             );

print start_html(-title=>'Genome Science Center - AnyPrimer', -script=>$jscript);
print start_form(-name=>'f1', -action=>$script, -method=>'post');
print br, h3({-align=>'center'},font({-face=>'Arial',-color=>"slateblue",-size=>'3'}, $label));
print table({-border=>1, -align=>"center", -bgcolor=>"whitesmoke"}, Tr(td($table))),br;
print end_form;
print end_html;

}
########################### DOCUMENTATION ##################################


=pod


=head1 NAME

 genome primer

=head1 DESCRIPTION


 Web interface for PCR primer design using primer3.  User supplies gene
 name and primer options.  Parameters are processed and passed to primer3
 for primer design, and e-PCR is used to check for expected and unexpected
 priming in other genomic locations.  Output is diplayed graphically,
 showing relative positions of primers, and Q values.  Nested primers
 are also designed if requested.


=head1 PARAMETERS


=head2 primer3 parameters

 User is able to specify:
 
   - Number of primer sets

   - PCR product size range

   - Primer size range

   - Primer Tm range

   - Maximum primer3 Q value

   - CG clamp [optional]
  
         Specify number of C or G bases that must occur at the 3'
         primer end.

   - Target Region coordinates [optional]
 
         Genomic positions of start and end of PCR target region.
         Unless specified, the middle of the gene will be targeted.

         These coordinates must be consistant with annotations in GenBank.

   - Allow primers in nearby genes

         Default will allow primer3 to design primers that may overlap
         with neighboring genes.  If disallowed, PCR product size may
         be reduced to avoid primers in neighboring genes.

   - Nested sets
 
         Specify number of nested primer sets to design.
 
         Pair with : Nested primers may be designed to pair with the
         left or right external primer.  Default is to design a left
         and right nested primer pair ['none' option].


=head2 e-PCR parameters

   - Word size

         Number of bases with exact match to 3' end of the primer.

   - Allowed mismatch

         Number of mismatches in each primer sequence, but not within
         specied word size from 3' end.

=cut

