#!/usr/bin/perl
use strict;
use warnings;
# Turn these to 0 to turn off debug display, or delete the appropriate lines below
my $dbg_OPS_LIST=1;
my $dbg_OUTPUT=1;
my $sequence="GGCGCAACGCTGAGCAGCTGGCGCGTCCCGCGCGGCCCCAGTTCTGCGCAGCTTCCCGAGGCTCCGCACCAGCCGCGCTTCTGTCCGCCTGCAGGGCATT";
# Break output after every Nth character
my $break = 50;
# Array of operations to perform at particular character positions in the sequence
my @ops;
# Add line breaks to our operations list
{
my $i=1;
while (length($sequence) > $i*$break+1) {
push @ops, [ $i*$break+1, 'BREAK' ];
++$i;
}
}
### Build color-switch operations: Each column position in the input
### file must be RED, all others should be black.
my $seqlen = length ($sequence);
my $input = "pm1103009.data";
open( my $infile, "<", $input ) || die "Check the $input $!\n";
my $old = -1;
while ( my $line = <$infile> + 0 ){
if ($line > $old+1) {
# skip sequential numbers (don't need to switch to 'red' on
# *every* character in reject sequence)
# add "switch to black" operation (unless we're still at start)
push @ops, [ $old, 'BLACK' ] unless $old < 0;
push @ops, [ $line, 'RED' ];
}
$old = $line;
}
close ($infile);
### remove any color switches after the switch to blue
@ops = grep {
# Keep all ops before 10 chars before the end
$_->[0] < length($sequence)-10
# Keep only 'BREAK' (noncolor) entries from then on
or $_->[1] eq 'BREAK'
} @ops;
### Add operation to switch to BLUE at 10 chars before the end
push @ops, [ length($sequence)-10, 'BLUE' ];
### Add DONE operation at end
push @ops, [ length($sequence), 'DONE' ];
### Sort the operations by column
@ops = sort { $a->[0] <=> $b->[0] } @ops;
### Display our operation list
if ($dbg_OPS_LIST) {
print "\nFinal operations list:\n";
for my $r (@ops) {
printf "% 3u: <%s>\n", $r->[0], $r->[1];
}
print "\n";
}
### Now build our HTML file
open(AA, ">fragments.html") or die $!;
print AA q(
Colored Gene Walk
);
my $pos = 1;
while ($pos < length($sequence)) {
# Get the next operation from the list:
my ($col, $op) = @{shift @ops};
$dbg_OUTPUT && print "LOOP: POS:$pos, COL:$col, OP:$op\n";
# Print the bit of the sequence up to the operation (if any)
if ($pos < $col) {
my $len = $col-$pos;
my $subseq = substr($sequence, $pos-1, $len);
$dbg_OUTPUT && print "\tTEXT($pos-$col): <$subseq>\n";
print AA $subseq;
}
# perform the operation
if ($op eq 'BLACK') {
$dbg_OUTPUT && print "\tBLACK($col)\n";
print AA '';
}
elsif ($op eq 'BREAK') {
$dbg_OUTPUT && print "\tBREAK($col)\n";
print AA '
';
}
elsif ($op eq 'BLUE') {
$dbg_OUTPUT && print "\tBLUE($col)\n";
print AA '';
}
elsif ($op eq 'RED') {
$dbg_OUTPUT && print "\tRED($col)\n";
print AA '';
}
elsif ($op eq 'DONE') {
$dbg_OUTPUT && print "END LOOP\n";
print AA '', "\n";
}
$pos = $col;
}
####
$ perl pm1103009.pl
Final operations list:
11:
25:
51:
51:
60:
86:
90:
100:
LOOP: POS:1, COL:11, OP:RED
TEXT(1-11):
RED(11)
LOOP: POS:11, COL:25, OP:BLACK
TEXT(11-25):
BLACK(25)
LOOP: POS:25, COL:51, OP:BREAK
TEXT(25-51):
BREAK(51)
LOOP: POS:51, COL:51, OP:RED
RED(51)
LOOP: POS:51, COL:60, OP:BLACK
TEXT(51-60):
BLACK(60)
LOOP: POS:60, COL:86, OP:RED
TEXT(60-86):
RED(86)
LOOP: POS:86, COL:90, OP:BLUE
TEXT(86-90):
BLUE(90)
LOOP: POS:90, COL:100, OP:DONE
TEXT(90-100):
END LOOP