#!/bin/env perl

use strict;
use warnings;
use Bio::TreeIO;

## set wildcard for query seqs in the tree
my $wild = 'UNK';
my $zero_thresh = 0.005;

## Set normalization twin pairs
my @nppref = ('refa-', 'refb-');
my @npnode = ();

## Set normalized distance cutoff for nearest neighbor
## (empirically derived default = 2.5)
my $dcut = 2.5;

## Read tree
my $treef = shift;
my $treein = new Bio::TreeIO(-file=>$treef, -format=>'newick');
while(my $tree = $treein->next_tree){
    my @query = ();
    my %leaves = ();
    ## Loop through leaves to find groups
    my ($last, $group, $leafnum) = (undef, 1, 1);
    for my $leaf ($tree->get_leaf_nodes){
	if($leaf->id =~ m/^$nppref[0]/){
	    $npnode[0] = $leaf;
	}elsif($leaf->id =~ m/^$nppref[1]/){
	    $npnode[1] = $leaf;
	}
	my @id = split(/_+/, $leaf->id);
	if(defined $last){ ## Every pass except the first
	    unless($last eq $id[-1] || $last eq $wild){ ## begin a new group
		$group += 1;
	    }
	}
	$last = $id[-1];
	$leaves{$leafnum} = {
	    'group'	=> $group, 
	    'id'	=> $leaf->id,
	    'spec'	=> $id[-1],
	    'node'	=> $leaf
	};
	## Record queries
	push @query, $leafnum if($id[-1] eq $wild);
	$leafnum += 1;
    }
    foreach my $q (@query){
	## Get distances to knowns
	my %distfromq = ();
	foreach my $n (keys %leaves){
	    if($q != $n && $leaves{$n}{'spec'} ne $wild){
		$distfromq{$n} = $tree->distance(-nodes => [$leaves{$q}{'node'}, $leaves{$n}{'node'}]);
	    }
	}
	## Sort distances
	my @o = sort {$distfromq{$a} <=> $distfromq{$b}} keys %distfromq;
	## Get zero distances
	my @z = ();
	#print STDERR "query $q\n";
	foreach my $o (@o){
	    #print STDERR "\t $distfromq{$o}\n";
	    if($distfromq{$o} <= $zero_thresh){
		push @z, $o if($distfromq{$o} >= 0);
	    }else{
		last;
	    }
	}
	my $forcedpred = 'no_force_needed';
	my $pred = 'no_pred_made';
	my $hit = 'NA';
	if(scalar(@z) > 0){ ## query has zero length known neighbors
	    ($pred, $hit) = ($leaves{$z[0]}{'spec'}, $leaves{$z[0]}{'id'});
	    $hit =~ s/^(\S+)_.+$/$1/;
	}else{
	    #check it out
	    ($pred, $hit) = checkclade($q, $q-1, $q+1, $wild, $tree, %leaves);
	    if($pred eq 'deeperdive'){
		## deeper dive bested on closest 2 to deal with nodes at local extremes
		## force a prediction if still none
		($pred, $hit, $forcedpred) = deeperdive($q, $tree, $o[0], $o[1], %leaves);
		$hit =~ s/^(\S+)_.+$/$1/;
	    }
	}
	my $normdist = $tree->distance(-nodes => [$npnode[0], $npnode[1]]);
	my $nn = sprintf("%.3f", $distfromq{$o[0]} / $normdist);
	my ($nnscore, $snnscore) = (0,0);
	if($nn < $dcut){
	    $snnscore = getscore($dcut, $normdist, \%distfromq, \%leaves, @o);
	    $nnscore = calcscore($dcut, $nn);
	}
	print join("\t", $leaves{$q}{'id'}, $pred, $hit, $forcedpred, $nn, $nnscore, $snnscore) . "\n";
    }
}

sub checkclade{
	my ($query, $lo, $hi, $wc, $tree, %l) = @_;
	if(exists $l{$lo} && exists $l{$hi}){ ## Not first or last
	    if($l{$lo}{'spec'} eq $wc){ ## lower bound is wildcard
		checkclade($query, $lo-1, $hi, $wc, %l);
	    }elsif($l{$hi}{'spec'} eq $wc){ ## upper bound is wildcard
		checkclade($query, $lo, $hi+1, $wc, %l);
	    }else{
		## Get the lca's descendants and check specs
		my $lca = $tree->get_lca(-nodes => [$l{$lo}{'node'},$l{$hi}{'node'}]);
		my ($spec, $iname, $pass) = (undef, undef, 1);
		for my $child ($lca->get_all_Descendents){
		    if($child->is_Leaf){
			my @id = split(/_/, $child->id);
			if(defined $spec){
			    unless($id[-1] eq $spec || $id[-1] eq $wc){
				$pass = 0;
			    }
			}else{
			    $spec = $id[-1];
			    $iname = $id[0];
			}
		    }
		}
		if($pass == 0){
		    return ('deeperdive', 'NA');
		}else{
		    return ($spec, $iname);
		}
	    }
	}else{ ## First or last
	    return ('deeperdive', 'NA');
	}
}

sub deeperdive{
    my ($query, $tree, $n, $p, %l) = @_;
    ## Want q to nearest dist to be less than nearest to pannearest dist
    my $q_to_n = $tree->distance(-nodes => [$l{$query}{'node'},$l{$n}{'node'}]);
    my $n_to_pn = $tree->distance(-nodes => [$l{$n}{'node'},$l{$p}{'node'}]);
    my $q_to_pn = $tree->distance(-nodes => [$l{$query}{'node'},$l{$p}{'node'}]);
    if($q_to_n < $n_to_pn && $l{$n}{'spec'} eq $l{$p}{'spec'}){
	return ($l{$n}{'spec'}, $l{$query}{'id'}, 'no_force_needed');
    }elsif($q_to_n == $q_to_pn && $l{$n}{'spec'} ne $l{$p}{'spec'}){
	return ('no_confident_result', 'NA', 'no_confident_result');
    }else{
	my $parent = $l{$query}{'node'}->ancestor;
	my @sister = sort {$tree->distance(-nodes => [$l{$query}{'node'},$a]) <=> $tree->distance(-nodes => [$l{$query}{'node'},$b]) } $parent->get_all_Descendents;
	foreach my $sis (@sister){
	    if($sis->is_Leaf && $sis->id ne $l{$query}{'id'}){
		my @fc = split(/_+/, $sis->id);
		return ('no_confident_result', 'NA', $fc[-1]);
		last;
	    }
	}
	return ('no_confident_result', 'NA', 'no_confident_result');
    }
}

sub getscore{
    my ($scaleto, $nd, $dref, $lref, @o) = @_;
    my %dist2q = %$dref;
    my %leaf = %$lref;
    my $score = 0;
    my $nnspec = $leaf{$o[0]}{'spec'};
    foreach my $o (@o){
	my $curspec = $leaf{$o}{'spec'};
	if($nnspec eq $curspec){
	    my $tmpscore = calcscore($scaleto, $dist2q{$o} / $nd );
	    if($tmpscore > 0){
		$score += $tmpscore;
	    }else{
		last;
	    }
	}else{
	    last;
	}
    }
    return sprintf("%.3f", $score);
}

sub calcscore{
    my ($scaleto, $distance) = @_;
    if($distance >= $scaleto){
	return 0;
    }else{
	return ($scaleto - $distance) / $scaleto;
    }
}
