# -*-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.                      #
#######################################################################

package AceTools;

##########################################
#
# Constructor
#
##########################################

%Sequence = ();
%DNA = ();
%BaseQuality = ();
%BasePosition = ();

sub new { 

    my ($pkg_ref, $ace_file)=@_;

    my $ace={};
    bless $ace ;
    $ace->readAce($ace_file);
    $ace;

}


#########################################################
#
# Read ace file given a file name
#
#########################################################

sub readAce {

    my($pkg_ref, $ace_file)=@_;

    open (ACE, "$ace_file") 
        || die "Can't open ace file: \"$ace_file\": $!\n";

    $pkg_ref->readAceFile(ACE);

    close(ACE);

}


#########################################################
#
# Read ace file given a file handle.
# Defines %DNA, %Sequence, etc globally for this package
#
#########################################################

sub readAceFile {

    my ($pkg_ref, $file)=@_;

    while (<$file>) {
        s/\/\/.*// ;			# ace file comments
        if ( /^DNA\s+(:\s+)?(\S+)/ ) {
            my $name = $2;
	    my @x = ();
	    while (<$file>) {
		last if /^\s*$/ ;
		s/\s+//g ;		# remove whitespace
		push(@x,$_);
	    }
	    $DNA{$name} = join("",@x);
	}
	elsif ( /BaseQuality\s+(:\s+)?(\S+)/ ) {
            my $name = $2 ;
	    my @x = ();
	    while (<$file>) {
		last if /^\s*$/ ;

		push(@x,$_);
	    }
	    $BaseQuality{$name} = join("",@x);
	}
	elsif ( /^(\S+)\s+(:\s+)?(\S+)/ ) {
	    my $class = $1 ;
	    my $name = $3 ;
	    #if (! defined(%{$class})) { push(@classes, \%{$class}); }
	    my @x = ();
	    while (<$file>) {
		last if /^\s*$/ ;
		s/\\\n$// ;		# continuation lines
		push(@x,$_);
	    }
	    if (! defined($$class{$name})) { $$class{$name} = ""; } # Keep perl -w happy
	    $$class{$name} .= join("",@x);
	}
	if (eof($file)) { last ; }
    }

}

#########################################################
# writeSomeAceFile(HANDLE);
# 
# Dump out ace file to HANDLE
#
# WARNING:
# Assumes for every DNA object there's also a Sequence
# object with the same key.
# 
#########################################################
sub writeSomeAceFile {

    local($type, $file, $excl_ref)=@_;

    my @exclude;
    my $contig;
    foreach $contig (@{$excl_ref}) {
	push(@exclude, $contig, &theReads($contig));
    }

    my ($key, $i);
    foreach $key (keys %DNA) {

	if (grep($key=$_, @exclude)) {
	    next;
	}

	$type->writeAceObject($file, $key);
    }

}



#########################################################
# writeAceObject($type, $file, $key)
# 
# Write one ace oject for key to HANDLE $file.
# Returns non-zero on error.
# 
#########################################################
sub writeAceObject {

    my ($type, $file, $key)=@_;

    unless ($Sequence{$key} && $DNA{$key}) {
	return 1;
    }

    print $file "\nDNA ",$key,"\n";
    my $len = length ($DNA{$key});
    for ($i = 0 ; $i < $len ; $i += 60) {
	print $file substr ($DNA{$key}, $i, 60), "\n" ;
    }

    print $file "\nSequence ",$key,"\n";
    print $file $Sequence{$key};

    0;

}

#########################################################
#
# Return a list of contig names as denoted by the
# 'Is_contig' tag.
#
#########################################################
sub theContigs {
    grep($Sequence{$_} =~ /Is_contig\n/, (keys(%Sequence)) ) ;
}


#########################################################
#
# Return a list of read names as denoted by the
# 'Is_read' tag.
#
#########################################################
sub theReads {

    my($type, $key)=@_;

    if ($key) {

	my $read;
	my @reads;
	foreach ( split("\n", $Sequence{$key}) ) {
	    if (($read) = /^Assembled_from\s+(\S+)/) {
		push(@reads, $read);
	    }
	}
	return (@reads);
    } else {
	return(grep($Sequence{$_} =~ /Is_read\n/,keys %Sequence));
    }

}



#########################################################
#
# Return DNA seq for $contig
# 
#########################################################

sub getDNA {

    my ($pkg_ref, $contig)=@_;

    return $DNA{$contig};

}

#########################################################
#
# Return Consensus qualities for $contig
# 
#########################################################
sub getBaseQuality {

    my ($pkg_ref, $contig)=@_;

    return $BaseQuality{$contig};

}

#########################################################
#
# Get tag - attempt to support ACE and CAF
# 
#########################################################

sub getTagCoords {

    my ($pkg_ref, $read, $tagtype)=@_;

    my @taglist = ();
    foreach (split(/\n/,$Sequence{$read})) {
	if(/\S+\s+$tagtype\s+(\d+)\s+(\d+)/) {
	    push(@taglist,[$1,$2]);
	}
    }
    return \@taglist;
}


#########################################################
#
# Read %DNA and get the lengths of the contig seqs.
# Return a hash reference to Contig/Length
#
#########################################################
sub readContigLengths {

    my ($pkg_ref)=@_;

    my %lengths = ();

    foreach (&theContigs) {
	$lengths{$_} = length($DNA{$_});
    }

    return \%lengths;

}

sub getAfEntries {

    my ($pkg_ref, $contig)=@_;

    return $pkg_ref->tableAfEntries($contig);

}


sub getSequence {

    my ($pkg_ref, $read)=@_;

    return $Sequence{$read};

}


#########################################################
#
# Get assembled_from info for given sequence object
# (supplied as string.)
# 
# Discards all else.
#
#########################################################
sub tableAfEntries {

    my ($pkg_ref, $contig)=@_;

    my (@af, $read, $c1, $c2, $r1, $r2);

    @af = ();

    foreach ( split("\n", $Sequence{$contig}) ) {

	if (($read, $c1, $c2, $r1, $r2) = /^Assembled_from\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/) {
	
            if ($r1 <= $r2) {
                push(@af,[$read,$c1,$c2,$r1,$r2]);
            } else {
                push(@af,[$read,$c2,$c1,$r2,$r1]);
            }

	}
    }

    return(\@af);

}


#########################################################
#
# Extract from Sequence object for
# specified contig, table of tag consenus
# tags of specified type.
#
#########################################################

sub getConsensusTags {

    my ($this, $contig, $tagtype)=@_;

    my @tags = ();

    foreach ( split("\n", $Sequence{$contig}) ) {

	# Tag AMBG 1005 1074
    	if ( /^Tag\s+(\S+)\s+(\d+)\s+(\d+)/ ) {
	    push(@tags, [$2,$3]) if $1 eq $tagtype;
	}

    }

    return \@tags;

}


#########################################################
#
# Return list ref to base quality for 
# this contig.
#
#########################################################

sub getConsensusQuality {

    my ($this, $contig)=@_;

    my @qual = split(/\s+/, $BaseQuality{$contig});

    return \@qual;
    
}

1;
