Foro - Perl en Español

#!/usr/bin/perl -l
#
# Extracción de la secuencia de las partes codificantes (CDS)
# Joaquín Ferrero. Julio 2009
#
use strict;
use warnings;
use diagnostics;

my $seq = join '', qw(
    aagaggaggaaggaagatgcgagaaggcagaggaggagggagggagggaaggagcgcgga
    gcccggcccggaagctaggagccattccgtagtgccatcccgagcaacgcactgctgcag
    cttccctgagcctttccagcaagtttgttcaagattggctgtcaagaatcatggactgtt
    attatatgccttgttttctgtcaagacaccatgattcctggtaaccgaatgctgatggtc
    gttttattatgccaagtcctgctaggaggcgcgagccatgctagtttgatacctgagacg
    gggaagaaaaaagtcgccgagattcagggccacgcgggaggacgccgctcagggcagagc
    catgagctcctgcgggacttcgaggcgacacttctgcagatgtttgggctgcgccgccgc
    ccgcagcctagcaagagtgccgtcattccggactacatgcgggatctttaccggcttcag
    tctggggaggaggaggaagagcagatccacagcactggtcttgagtatcctgagcgcccg
    gccagccgggccaacaccgtgaggagcttccaccacgaagaacatctggagaacatccca
    gggaccagtgaaaactctgcttttcgtttcctctttaacctcagcagcatccctgagaac
    gaggtgatctcctctgcagagcttcggctcttccgggagcaggtggaccagggccctgat
    tgggaaaggggcttccaccgtataaacatttatgaggttatgaagcccccagcagaagtg
    gtgcctgggcacctcatcacacgactactggacacgagactggtccaccacaatgtgaca
    cggtgggaaacttttgatgtgagccctgcggtccttcgctggacccgggagaagcagcca
    aactatgggctagccattgaggtgactcacctccatcagactcggacccaccagggccag
    catgtcaggattagccgatcgttacctcaagggagtgggaattgggcccagctccggccc
    ctcctggtcacctttggccatgatggccggggccatgccttgacccgacgccggagggcc
    aagcgtagccctaagcatcactcacagcgggccaggaagaagaataagaactgccggcgc
    cactcgctctatgtggacttcagcgatgtgggctggaatgactggattgtggccccacca
    ggctaccaggccttctactgccatggggactgcccctttccactggctgaccacctcaac
    tcaaccaaccatgccattgtgcagaccctggtcaattctgtcaattccagtatccccaaa
    gcctgttgtgtgcccactgaactgagtgccatctccatgctgtacctggatgagtatgat
    aaggtggtactgaaaaattatcaggagatggtagtagagggatgtgggtgccgctgagat
    caggcagtccttgaggatagacagatatacacaccacacacacacaccacatacaccaca
    cacacacgttcccatccactcacccacacactacacagactgcttccttatagctggact
    tttatttaaaaaaaaaaaaaaaaaaggaaaaaatccctaaacattcaccttgaccttatt
    tatgactttacgtgcaaatgttttgaccatattgatcatatattttgacaaaatatattt
    ataactacgtattaaaagaaaaaaataaaatgagtcattattttaaaggtaaaaaaaaaa
    aaaaaaaa
);

my $cds = 'join(345..389,400..567,500..523)join(85..460,490..506)complement(join(675..679,789..797))';

print length $seq;

my $extracto = $cds;            # Inicializamos el extracto al valor inicial del CDS
my $extracto_anterior = '';     # Esta nos servirá para ver los cambios entre cada ciclo
print $extracto;

my $BASES   = qr/[catg]+/;      # Expresión regular que define cómo son las bases
my $INDICES = qr/\d+/;          # Expresión regular que define cómo son los índices

while ($extracto_anterior ne $extracto) {          # Mientras existan cambios ...
    $extracto_anterior =  $extracto;                   # Guardamos el estado actual

    ## Empezamos a modificar el $extracto
    # Rangos de índices, sustituidos por la cadena de la secuencia
    $extracto =~ s/($INDICES)\.\.($INDICES)/substr($seq,$1-1,$2-$1+1)/ge;

    # Cadenas de bases contiguas, quitamos las comas
    $extracto =~ s/($BASES),($BASES)/$1$2/g;

    # Eliminación de join(). Nos quedamos solo con las bases
    $extracto =~ s/join\(($BASES)\)/$1/g;

    # Eliminación de complement(). Lo sustituimos por la complementaria
    $extracto =~ s/complement\(($BASES)\)/complement($1)/ge;
}

print $extracto;

sub complement {        # Cálculo de la complementaria
    my $subseq = shift;
    $subseq =~ tr/CATGcatg/GTACgtac/;    # Cambio letra a letra
    return $subseq;
}

__END__