#!/usr/bin/perl -w

# This Perl script takes tRNAdb-CE v.8 tRNA sequence record data in
# Fasta format and outputs that data annotated/augmented with 3'end
# annotations/mapping to Sprinzl coordinates in the sequence
# descriptions and possible warnings/conditions as described in Ardell
# and Hou (2015) intended for the journal RNA. This script is
# distributed under the same terms and conditions among all
# supplementary materials of Ardell and Hou (2015) and in particular
# under the Artistic License of Perl itself as allowable by law.

# Copyright (2015) David H. Ardell 
# all wrongs reversed.


use Getopt::Std;
use Bio::SeqIO;
use vars qw($VERSION $DESC $opt_h $opt_f);
$VERSION = 0.1;
$DESC    = "";
$NAME    = $0;
$NAME    =~ s/^.*\///;

# Command-line options:
$opt_f = 'fasta';
$opt_M = 4;
$opt_m = 1;
$opt_U = 1;
$opt_g = -5;
$opt_P = 12;
$opt_p = 5;


&getopts('hf:m:M:U:g:P:p:');

$M = $opt_M; #MATCH-PAIR BONUS
$m = $opt_m; #MISMATCH-PAIR BONUS 
$U = $opt_U; #BONUS FOR A MATCHING PAIR WITHIN ANNOTATED BODY
$g = $opt_g; #GAP PENALTY
$P = $opt_P; #NUMBER OF BASES SEARCHED AMONG ANNOTATED TPE
$p = $opt_p; #NUMBER OF BASES SEARCHED IN TPL

@{ $pairs{G} } = qw/ C c T t U u /;
@{ $pairs{g} } = qw/ C c T t U u /;
@{ $pairs{C} } = qw/ G g /;
@{ $pairs{c} } = qw/ G g /;
@{ $pairs{A} } = qw/ T t U u/;
@{ $pairs{a} } = qw/ T t U u/;
@{ $pairs{T} } = qw/ A a G g /;
@{ $pairs{t} } = qw/ A a G g /;
@{ $pairs{U} } = qw/ A a G g /;
@{ $pairs{u} } = qw/ A a G g /;

foreach my $fp (qw/ G g C c A a T t U u N n R r Y y W w S s M m K k/) {
  foreach my $tp (qw/ G g C c A a T t U u N n R r Y y W w S s M m K k/) {
    $S{$fp}{$tp} = $m;
  }
}

foreach my $fp (qw/ G g C c A a T t U u /) {
  foreach my $tp (@{ $pairs{$fp} }) {
    $S{$fp}{$tp} = $M;
    if ($fp =~ /[[:upper:]]/ and $tp =~ /[[:upper:]]/) { 
      $S{$fp}{$tp} += $U;
    }
  }
}

if ($opt_h) {
  print STDERR <<"QQ_HELP_QQ";
 
  $NAME $VERSION
  $DESC
  Copyleft 2001-2015 David H. Ardell
  All wrongs reversed.

QQ_HELP_QQ
  exit 1;
}

sub DP (){
  my ($fp,$tp) = @_;
  my $BT = [];
  my @S = ();
  my ($maxS,$len) = (0,0);
  my $maxij = [];
  for (0..scalar(@$fp)) {
    $S[$_][0] = 0;
    $$BT[$_][0] = 0;
  }
  for (0..scalar(@$tp)) {
    $S[0][$_] = 0;
    $$BT[0][$_] = 0;
  }
  foreach my $i (1..scalar(@$fp)) {
    foreach my $j (1..scalar(@$tp)) {
      my ($sl,$sa,$sd,$zero);
      $$sl = $S[$i][($j - 1)] + $g; 
      $$sa = $S[($i - 1)][$j] + $g;
      $$sd = 0;
      if (exists $S{ $$fp[($i - 1)] }{ $$tp[($j - 1)] } ){
	$$sd = $S[($i - 1)][($j - 1)] + $S{ $$fp[($i - 1)] }{ $$tp[($j - 1)] };
      }
      else {
	warn join "","WARN: unexpected sequence character on input, either ",$$fp[($i - 1)]," or ", $$tp[($j - 1)],"\n";
      }
      $$zero = 0;
      my @sort = sort {$$a <=> $$b} ($sl,$sd,$sa,$zero);
      my $max = $sort[-1];
      $S[$i][$j] = $$max;
      unless ($max == $zero) {
	if ($max == $sd) {
	  $$BT[$i][$j] = "d";
	}
	elsif ($max == $sl) {
	  $$BT[$i][$j] = "l";
	}
	else {
	  $$BT[$i][$j] = "a";
	}
      }
      else {
	$$BT[$i][$j] = 0;
      }
      if ($$max > $maxS) {
	$maxS = $$max;
	$maxij = [$i,$j];
      }
    }
  }
  return ($maxS,$maxij,$BT);
}

sub computeStem (){
  my ($fp,$tp,$maxS,$maxij,$BT,$seqid) = @_;
  my @steml = ();
  my @stemr = ();
  ## compute the unpaired portion of the 3p stem 
  my $srj = 0; 
  if ( $$BT[$$maxij[0]][$$maxij[1]] =~ /[dl]/) {
    $srj = $$maxij[1];
  }
  elsif ( $$BT[$$maxij[0]][$$maxij[1]] eq 'a') {
    $srj = $$maxij[1] + 1;
  }
  else {
    warn "WARN: unexpected backtrace state.\n";
  }
  my @stemr_remainder = ();
  push @stemr_remainder, @$tp[$srj..$#$tp];
  my ($i,$j) = @$maxij;
  while ($$BT[$i][$j] and $$BT[$i][$j] ne "0"){
    if ($$BT[$i][$j] eq "d"){
      push @steml,$$fp[($i-1)];
      push @stemr,$$tp[($j-1)];
      ($i,$j) = (($i - 1),($j - 1));
    }
    elsif ($$BT[$i][$j] eq "l"){
      push @steml,'-';
      push @stemr,$$tp[($j-1)];
      ($i,$j) = (($i),($j - 1));
    }
    elsif ($$BT[$i][$j] eq "a"){
      push @steml,$$fp[($i-1)];
      push @stemr,'-';
      ($i,$j) = (($i - 1),($j));
    }
  }
  unless (defined $$BT[$i][$j]) {
    die "UNEXPECTED BACKTRACE condition with seqid $seqid.\n";
  }
  my $steml = join "",@steml;
  my $stemr = join "",reverse @stemr;
  my $idbase = shift @stemr_remainder;
  my $cca    = join "", (splice @stemr_remainder,0,3);
  my $len    = length $steml;
  return ($steml,$stemr,$idbase,$cca,$len);
}


$IN = Bio::SeqIO->new(-fh => *STDIN{IO}, '-format' => $opt_f);
$OUT = Bio::SeqIO->newFh('-format' => $opt_f);
while (my $seq = $IN->next_seq()) {
    my $seqseq = $seq->seq;
    my $seqid = $seq->id;
    my $seqdesc = $seq->desc;
    my $fp = [];
    my $tp = [];
    my @warnings = ();
    if ($seqseq =~ /[a-z]{2}([A-Z]{7})([A-Z]{2})/) { 
      $fpstem = $1;
      @$fp = reverse split //,$fpstem;
      $ta = $2;
    }
    else {
      warn "WARN: 5prime match error on seqid $seqid\n";
    }
    if ($seqseq =~ /([A-Z]{$P}[a-z][a-zA-Z]{$p})[\w-]*$/) { 
      $tpstem = $1;
      @$tp = split //,$tpstem;
    }
    else {
      warn "WARN: 3prime match error on seqid $seqid\n";
    }
    my ($maxS,$maxij,$BT) = &DP($fp,$tp);
    my ($steml,$stemr,$id,$cca,$len) = &computeStem($fp,$tp,$maxS,$maxij,$BT,$seqid);
    push @warnings, "W:CCApredicted" if ($cca =~ /CCA/);
    if ($cca =~ /cca/i) {
      push @warnings, "W:cca";
    }
    elsif ($cca =~ /^cc/i) {
      push @warnings, "W:cc";
    }
    push @warnings, "W:shortLength" if ($len < 7);
    push @warnings, "W:pos89nTA" if ($ta ne 'TA');
    push @warnings, "W:tCE_5prime_error" if ($steml =~ /[a-z]/);
    push @warnings, "W:tCE_3prime_error" if ($stemr =~ /[a-z]/);
    $seqdesc = join " ",$seqdesc,"STEML:$steml","STEMRS:$stemr","ID:$id","CCA:$cca","LEN:$len","SCORE:$maxS","pos8,9:$ta",@warnings;
    $seq->desc($seqdesc);
    print $OUT $seq; 
  }