#!/usr/bin/env perl   

#  -*- perl -*-

use strict;
use warnings FATAL => qw ( all );
use Data::Dumper;
use Formats;
use Errors;
use GD;

# Ebbe Sloth Andersen, January 2005.

# ALISTEM_PLOT: Visualises alignment and common pairing mask in the column format. 
# Uses color_r, color_g, color_b to make a representation of the alignment 
# and below that a linear stem plot of the pairing mask correlations.
# Makes this for several structural groups.

# >>>>>>>>>>>>>>>>>> ALISTEM PLOT <<<<<<<<<<<<<<<<<<<<<<

my ( $entries, $file, $header );

( $file ) = @ARGV;
( $header, $entries ) = &Formats::read_col ( $file );
&Errors::check_col ( $entries, { "TYPE" => ["RNA"] } );
&alistem_groups ( $entries );

# >>>>>>>>>>>>>>>>>> SUBROUTINES <<<<<<<<<<<<<<<<<<<<<<<

sub alistem_groups
{
    # Ebbe Sloth Andersen, July 2005.

    my ( $entries ) = @_;

    # Returns nothing.

    my ( $line,        # input lines
	 %colors1,
	 %colors2,
	 @rnas,
	 $rna,
	 @cols,
	 $TYPE,        
	 $cols,
	 $col,
	 $rows,
	 @COL,         # any number of columns
	 $ENTRY, 
	 @data, 
	 $i,           # counting numbers
	 $length,
	 $counter,
	 $im,
	 @r, @g, @b,
	 $r,
	 @residues,
	 $x, $y, 
	 $color,
         @stem,        # plot analysis area
         $align_bp, 
         $alignpos, 
         $baseline, 
         $m, $n, 
         $pix, 
         $middle,
         @label,       # variables for align_bp
         $ll, 
         $lab, 
         $gap, 
         $a, 
         $end, 
         @alignpos, 
         @labpos, 
         $here, 
         $count, 
         $there,
         $pm, 
         @pm, 
         $c,
         @residue,
         $residue,
         @overlap,      # investigate overlap
         $prev, 
         $stem, 
         $overlap,
         $t,            # make overlap stem
         $dot, 
         $succes,
         );
    
    %colors1 = (
		"red"       => [1.00, 0.00, 0.00],
		"orange"    => [1.00, 0.50, 0.00],
		"yellow"    => [1.00, 1.00, 0.00],
		"green"     => [0.00, 1.00, 0.00],
		"purple"    => [0.93, 0.51, 0.93],
		"blue"      => [0.00, 0.00, 1.00],
		"grey"      => [0.70, 0.70, 0.70]
		);
    
    %colors2 = (
		"white"     => [255, 255, 255],
		"black"     => [  0,   0,   0],
		"grey"      => [128, 128, 128],
		"red"       => [255,   0,   0],
		"lime"      => [  0, 255,   0],
		"green"     => [  0, 128,   0],
		"blue"      => [  0,   0, 255],
		"yellow"    => [  0, 255, 255]
		);

    # get length and number of RNA entries
    @rnas = grep { $_->{'TYPE'} eq "RNA" } @{ $entries };

    $rows = scalar @rnas;
    $rna = $rnas[0];    
    @cols = split ( /,/, $rna->{'residue'} );
    $cols = scalar @cols;

    # make space for doubledot and ali
    $rows = $rows * 2 + $cols;
    $cols = $cols * 2;

    $im = new GD::Image($cols, $rows);

    my $white = $im->colorAllocate(255,255,255);    
    my $black = $im->colorAllocate(0,0,0);
    my $grey = $im->colorAllocate(150,150,150);
    my $grel = $im->colorAllocate(200,200,200);

    my $red = $im->colorAllocate(255,0,0);
    my $orange = $im->colorAllocate(255,128,0);
    my $yellow = $im->colorAllocate(255,255,0);
    my $green = $im->colorAllocate(0,255,0);
    my $cyan = $im->colorAllocate(0,255,255);
    my $blue = $im->colorAllocate(0,128,255);

    my $red1 = $im->colorAllocate(255,128,128);
    my $red2 = $im->colorAllocate(255,179,179);
    my $red3 = $im->colorAllocate(255,230,230);

    my $orange1 = $im->colorAllocate(255,179,128);
    my $orange2 = $im->colorAllocate(255,204,179);
    my $orange3 = $im->colorAllocate(255,230,204);

    my $yellow1 = $im->colorAllocate(255,255,128);
    my $yellow2 = $im->colorAllocate(255,255,179);
    my $yellow3 = $im->colorAllocate(255,255,230);

    my $green1 = $im->colorAllocate(128,255,128);
    my $green2 = $im->colorAllocate(179,255,179);
    my $green3 = $im->colorAllocate(230,255,230);

    my $cyan1 = $im->colorAllocate(128,255,255);
    my $cyan2 = $im->colorAllocate(179,255,255);
    my $cyan3 = $im->colorAllocate(230,255,255);

    my $blue1 = $im->colorAllocate(128,128,255);
    my $blue2 = $im->colorAllocate(179,179,255);
    my $blue3 = $im->colorAllocate(230,230,255);

    my $grey1 = $im->colorAllocate(179,179,179);
    my $grey2 = $im->colorAllocate(204,204,204);
    my $grey3 = $im->colorAllocate(230,230,230);

# plot alignment

    $y = 0;    
    foreach $rna ( @rnas ) {
        @r = ( );
        @g = ( );
        @b = ( );
        $x = 0;
        $i = 0;
		
        # get color entries
        @residues = split ( /,/, $rna->{'residue'} );
        @r = split ( /,/, $rna->{'color_r'} );
        @g = split ( /,/, $rna->{'color_g'} );
        @b = split ( /,/, $rna->{'color_b'} );
        foreach $r ( @r ) {
            
            $color = $grey1;
            
            if ( $r[$i] == 1.00 && $g[$i] == 0.50 && $b[$i] == 0.50 ) { $color = $red1; }
            if ( $r[$i] == 1.00 && $g[$i] == 0.70 && $b[$i] == 0.70 ) { $color = $red2; }
            if ( $r[$i] == 1.00 && $g[$i] == 0.90 && $b[$i] == 0.90 ) { $color = $red3; }

            if ( $r[$i] == 1.00 && $g[$i] == 0.70 && $b[$i] == 0.50 ) { $color = $orange1; }
            if ( $r[$i] == 1.00 && $g[$i] == 0.80 && $b[$i] == 0.70 ) { $color = $orange1; }
            if ( $r[$i] == 1.00 && $g[$i] == 0.90 && $b[$i] == 0.80 ) { $color = $orange1; }
            
            if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.50 ) { $color = $yellow1; }
            if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.70 ) { $color = $yellow2; }
            if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.90 ) { $color = $yellow3; }

            if ( $r[$i] == 0.50 && $g[$i] == 1.00 && $b[$i] == 0.50 ) { $color = $green1; }
            if ( $r[$i] == 0.70 && $g[$i] == 1.00 && $b[$i] == 0.70 ) { $color = $green2; }
            if ( $r[$i] == 0.90 && $g[$i] == 1.00 && $b[$i] == 0.90 ) { $color = $green3; }
            
            if ( $r[$i] == 0.50 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan1; }
            if ( $r[$i] == 0.70 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan2; }
            if ( $r[$i] == 0.90 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan3; }
            
            if ( $r[$i] == 0.50 && $g[$i] == 0.50 && $b[$i] == 1.00 ) { $color = $blue1; }
            if ( $r[$i] == 0.70 && $g[$i] == 0.70 && $b[$i] == 1.00 ) { $color = $blue2; }
            if ( $r[$i] == 0.90 && $g[$i] == 0.90 && $b[$i] == 1.00 ) { $color = $blue3; }
            
            if ( $r[$i] == 0.70 && $g[$i] == 0.70 && $b[$i] == 0.70 ) { $color = $grey1; }
            if ( $r[$i] == 0.80 && $g[$i] == 0.80 && $b[$i] == 0.80 ) { $color = $grey2; }
            if ( $r[$i] == 0.90 && $g[$i] == 0.90 && $b[$i] == 0.90 ) { $color = $grey3; }
            
            if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $white; }
            
	    if ( $residues[$i] eq "-" ) { $color = $white; }	    
            
	    $im->filledRectangle($x, $y, ($x+1), ($y+1), $color);
	    $i++;
	    $x = $x + 2;
	}
	$y = $y + 2;
    }
    
# plot analysis area 

    @pm = grep { $_->{'TYPE'} eq "RNA" } @{ $entries };
    $c = 0;
    if ( defined $pm[0]->{'residue'} ) {
        $baseline = $y;
        $m = 0;
        $n = $baseline;
        $middle = $cols / 2;
        $cols = $cols-1;        
        for ( $m = 0; $m <= $middle; $m++ ) {
            $im->filledRectangle($m, $n, ($cols-$m), $n, $grey3);
            $n++;
        }
        
# make mountains for all RNAs
        @rnas = ( );
	@rnas = grep { $_->{'TYPE'} eq "RNA" } @{ $entries };
	
        foreach $rna ( @rnas ) {
            @stem = ( );
            @stem = split ( /,/, $rna->{'align_bp'} );
            $alignpos = 1;
            $m = 0;
            $n = 0;
            
            foreach $align_bp ( @stem ) {
                if ( $align_bp =~ /^(\d+)/ ) {
                    if ( $1 > $alignpos ) 
                    {
                        $x = 2 * ( $alignpos + ( ( $1 - $alignpos ) / 2 ) ) - 2;
                        $pix = ($alignpos * 2) - 2;
                        $n = $baseline;
                        for ( $m = $pix; $m < $x; $m++ ) {
                            $im->filledRectangle($m, $n, ($m+1), $n, $grey1);
                            $n++;
                        }
                    } 
                    elsif ( $1 < $alignpos ) 
                    {
                        $x = 2 * ( $1 + ( ( $alignpos - $1 ) / 2 ) );
                        $pix = ($alignpos * 2) - 2;
                        $n = $baseline;
                        for ( $m = $pix; $m >= $x; $m++ ) {
                            $im->filledRectangle($m, $n, ($m+1), ($n+1), $grey1);
                            $n++;
                            $m = $m - 2;
                        }
                    }
                }
                $alignpos = $alignpos + 1;
            }
        }        
	
# make mountains for pairingmask
        @rnas = ( );
	@rnas = grep { $_->{'TYPE'} eq "arbitrary" } @{ $entries };
	
        foreach $rna ( @rnas ) {
            @stem = ( );
            @stem = split ( /,/, $rna->{'align_bp'} );
            $alignpos = 1;
            $m = 0;
            $n = 0;
            
            foreach $align_bp ( @stem ) {
                if ( $align_bp =~ /^(\d+)/ ) {
                    if ( $1 > $alignpos ) 
                    {
                        $x = 2 * ( $alignpos + ( ( $1 - $alignpos ) / 2 ) ) - 2;
                        $pix = ($alignpos * 2) - 2;
                        $n = $baseline;
                        for ( $m = $pix; $m < $x; $m++ ) {
                            $im->filledRectangle($m, $n, ($m+1), $n, $grey1);
                            $n++;
                        }
                    } 
                    elsif ( $1 < $alignpos ) 
                    {
                        $x = 2 * ( $1 + ( ( $alignpos - $1 ) / 2 ) );
                        $pix = ($alignpos * 2) - 2;
                        $n = $baseline;
                        for ( $m = $pix; $m >= $x; $m++ ) {
                            $im->filledRectangle($m, $n, ($m+1), ($n+1), $grey1);
                            $n++;
                            $m = $m - 2;
                        }
                    }
                }
                $alignpos = $alignpos + 1;
            }
        }        
        
# make stems for all RNAs and on top of that the pairingmask
        
        @rnas = ( );
	@rnas = grep { $_->{'TYPE'} eq "RNA" } @{ $entries };
        
        @pm = ( );
        @pm = grep { $_->{'TYPE'} eq "pairingmask" } @{ $entries };
	
	foreach $pm ( @pm ) {
            push @rnas, $pm;
	}
        
        foreach $rna ( @rnas ) {
            @stem = ( );
            @stem = split ( /,/, $rna->{'align_bp'} );
            @r = ( ); 
            @g = ( ); 
            @b = ( ); 
            if ( defined $rna->{'color_r'} ) {
                @r = split ( /,/, $rna->{'color_r'} );
                @g = split ( /,/, $rna->{'color_g'} );
                @b = split ( /,/, $rna->{'color_b'} );
            } else {
                # enter grey color in all sites
                foreach $align_bp ( @stem ) {
                    push ( @r, "0.70" );
                    push ( @g, "0.70" );
                    push ( @b, "0.70" );
                }
            }
            
            $i = 0;
            $alignpos = 1;
            
            foreach $align_bp ( @stem ) {
                if ( $align_bp =~ /^(\d+)/ ) {
                    if ( $1 > $alignpos ) 
                    {
                        $x = 2 * ( $alignpos + ( ( $1 - $alignpos ) / 2 ) ) - 2;
                        $y = $baseline + $1 - $alignpos;
                    }	
                    elsif ( $1 < $alignpos ) 
                    {
                        $x = 2 * ( $1 + ( ( $alignpos - $1 ) / 2 ) );
                        $y = $baseline + $alignpos - $1;
                    }
                    
                    if ( $r[$i] == 1.00 && $g[$i] == 0.50 && $b[$i] == 0.50 ) { $color = $red1; }
                    if ( $r[$i] == 1.00 && $g[$i] == 0.70 && $b[$i] == 0.70 ) { $color = $red2; }
                    if ( $r[$i] == 1.00 && $g[$i] == 0.90 && $b[$i] == 0.90 ) { $color = $red3; }
                    
                    if ( $r[$i] == 1.00 && $g[$i] == 0.70 && $b[$i] == 0.50 ) { $color = $orange1; }
                    if ( $r[$i] == 1.00 && $g[$i] == 0.80 && $b[$i] == 0.70 ) { $color = $orange1; }
                    if ( $r[$i] == 1.00 && $g[$i] == 0.90 && $b[$i] == 0.80 ) { $color = $orange1; }
                    
                    if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.50 ) { $color = $yellow1; }
                    if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.70 ) { $color = $yellow2; }
                    if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.90 ) { $color = $yellow3; }
                    
                    if ( $r[$i] == 0.50 && $g[$i] == 1.00 && $b[$i] == 0.50 ) { $color = $green1; }
                    if ( $r[$i] == 0.70 && $g[$i] == 1.00 && $b[$i] == 0.70 ) { $color = $green2; }
                    if ( $r[$i] == 0.90 && $g[$i] == 1.00 && $b[$i] == 0.90 ) { $color = $green3; }
                    
                    if ( $r[$i] == 0.50 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan1; }
                    if ( $r[$i] == 0.70 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan2; }
                    if ( $r[$i] == 0.90 && $g[$i] == 1.00 && $b[$i] == 1.00 ) { $color = $cyan3; }
                    
                    if ( $r[$i] == 0.50 && $g[$i] == 0.50 && $b[$i] == 1.00 ) { $color = $blue1; }
                    if ( $r[$i] == 0.70 && $g[$i] == 0.70 && $b[$i] == 1.00 ) { $color = $blue2; }
                    if ( $r[$i] == 0.90 && $g[$i] == 0.90 && $b[$i] == 1.00 ) { $color = $blue3; }
                    
                    if ( $r[$i] == 0.70 && $g[$i] == 0.70 && $b[$i] == 0.70 ) { $color = $grey1; }
                    if ( $r[$i] == 0.80 && $g[$i] == 0.80 && $b[$i] == 0.80 ) { $color = $grey2; }
                    if ( $r[$i] == 0.90 && $g[$i] == 0.90 && $b[$i] == 0.90 ) { $color = $grey3; }
                    
                    if ( $r[$i] == 1.00 && $g[$i] == 0.00 && $b[$i] == 0.00 ) { $color = $red; }
                    if ( $r[$i] == 0.00 && $g[$i] == 1.00 && $b[$i] == 0.00 ) { $color = $green; }
                    if ( $r[$i] == 1.00 && $g[$i] == 1.00 && $b[$i] == 0.00 ) { $color = $yellow; }
                    
                    $im->filledRectangle(($x-1), ($y-1), $x, $y, $color);
                }
                $i++;
                $alignpos++;
            }
        }    
    }
    my $name;
    $file =~ /^(\S+)\.col$/;
    $name = $1;
    
    open(PNGFILE, ">", "$name.png");
    print PNGFILE $im->png;
    close(PNGFILE);
}

