#!/usr/local/bin/perl

# COPYRIGHT NOTICE

$TITLE =	'FramePlot';
$VERSION =	'2.3';
$COPYRIGHT =	'(c) 1996-1999, ISHIKAWA Jun';
$AUTHOR =	'jun@nih.go.jp';
$DATE =		'$Date: 1999/06/20 05:11:56 $';

# Permission is hereby granted, free of charge, to use the
# software for acadenic purpose and to copy the software provided
# that the COPYRIGHT NOTICE remains intact. For commercial use,
# you should contact the author for licensing details. The software
# is provided "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESSED OR
# IMPLIED. REDISTRIBUTION NOT PERMITTED. Credit for using this
# program must be given in your publication:
#
# Ishikawa, J. and Hotta, K. FEMS Microbiol. Lett. 174:251-253 (1999)
#
# REQUIREMENT
#
# perl version 5.001, 5.003 or later
#	<URL:http://www.perl.org/>
# fly version 1.6.0 or later
#	<URL:http://www.unimelb.edu.au/fly/fly.html>
#
# INSTALLATION
#
# 1. Save this file as frameplot.pl, frameplot.cgi, or etc.
#        Any filename is acceptable, because it is referred
#        by SCRIPT_NAME environment variable.
# 2. Specify following paths:
#
# Where is your fly binary?
$flyprog = "/usr/local/bin/fly";
# Where output image should go
$outpath = "/usr/local/apache/share/htdocs/frameplot";
# URL for $outpath
$outurl = "/frameplot";

#------------ No further configuration required -----------------

$DEBUG =   0;	# 0, 1, or 2
$LOGGING = 0;	# 0 or 1

$outfilename = "frame$$.gif";

$bgcolor = "#eeeeff";
$HelpDoc = "http://www.nih.go.jp/~jun/research/frameplot/help.html";


# Timeout: generate SIGALRM after 30 min.
alarm(1800);
$SIG{'INT'}=$SIG{'TERM'}=$SIG{'STOP'}=$SIG{'QUIT'}=$SIG{'ALRM'} = 'stop';

# clean $PATH
for $path (split /:/, $ENV{PATH}) {
    push @safepath, $path unless (/sbin|etc/oi);
}
$ENV{PATH} = join ":", @safepath;

if ($ENV{'REQUEST_METHOD'} eq "POST") {
    &getdata;
    if ($FORM{'x'} && $FORM{'y'}) {
	&param;
	&feature(split /:/, &findorf(&xy2pos($FORM{'x'}, $FORM{'y'})));
    }
    elsif ($FORM{'orf'}) {
	&feature(split /:/, $FORM{orf});
    }
    elsif ($FORM{'remove'}) {
	&removeresult;
    }
    else {
	&param;
	&cook;
	&drawimage;
	&resultpage;
    }
}
else {
    &mainpage;
}

exit;

#	SUBROUTINES
sub getdata {
    $DEBUG and $StartTime = time;

    if ($ENV{'REQUEST_METHOD'} eq "POST") {
 	read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	%FORM = &cgiparse($buffer);
    }

    $FORM{'sequence'} =~ tr/a-z/A-Z/;	# convert case
    $FORM{'sequence'} =~ tr/U/T/;	# substitute T for U
    $FORM{'sequence'} =~ tr/A-Z//cd;	# remove non-alphabetical chars
    $seq = $FORM{'sequence'};
}

sub param {

    @start = @cstart = @orf = @corf = {};

    $FORM{'label'} =~ s/[\n\r]/ /go;

    $seqlen  = length($seq);	    # sequence length (nucleotides)
    $winlen  = $FORM{'window'} * 3; # window length (nucleotides)
    $steplen = $FORM{'step'} * 3;   # step lenth (nucleotides)
    $minorf  = $FORM{'minorf'} * 3; # minimum ORF size (nucleotides)
    $seqmod3 = $seqlen % 3;	    # 

    if ($FORM{'width'} =~ /auto/io) {
	my $buffer = int($seqlen / 4.5);
	if ($buffer <= 300) {
	    $graphsize{'width'} = 300;  # minimum graph size
	}
	elsif ($buffer > 7000) {
	    $graphsize{'width'} = 7000; # maximum graph size
	}
	else {
	    $graphsize{'width'} = $buffer;
	}
    }
    else {
	$graphsize{'width'} = $FORM{'width'};
    }

    $graphsize{'height'} = 200;

    %margin = (left   =>  20,
	       right  =>  20,
	       top    => 160,
	       bottom =>  20);
    %imagesize = (width  => $margin{left}+$graphsize{width}+$margin{right},
		  height => $margin{top}+$graphsize{height}+$margin{bottom});

    # time stamp
    my($wday, $month, $day, $time, $year) = split /\s+/, localtime;
    $timestamp = "$month $day $time $year";
    $today = "$day-$month-$year";
}

sub cook {
    my($found,$codon,$frame,$pos,$count,$i,$j,@gcmark,$flag);

    # indexing G/C position (from camel book:-)
    for $lookfor ("G","C","S") {
	$pos = -1;
	while (($pos = index($seq, $lookfor, $pos)) > -1) {
	    $gcmark[$pos]++; # faster than hash
	    $pos++;
	}
    }

    # Average GC%
    ($DEBUG > 1) and $AvGCStartTime = time;
    $count = $seq =~ tr/GCS/GCS/;	# the fastest method I think:-)
    $avgc = sprintf("%4.1f", ($count / $seqlen) * 100);
    ($DEBUG > 1) and $AvGCEndTime = time;

    # 3rd-letter GC%
    ($DEBUG > 1) and $ThirdGCStartTime = time;
    for $frame (0 .. 2) {
	for ($i = $frame; $i < $seqlen - $winlen; $i += $steplen) {
	    $count = 0;
	    for ($j = $i + 2; $j < $i + $winlen; $j += 3) {
		$count++ if $gcmark[$j];
	    }
	    push @{$gc[$frame]}, $count / $FORM{window} * 100;
	}
    }
    ($DEBUG > 1) and $ThirdGCEndTime = time;

    # Normal strand
    ($DEBUG > 1) and $NormalStartTime = time;
    if ($FORM{incorf} eq "ON") { # virtual start codon
	for $i (1 .. 3) {
	    my $c = substr($seq, $i-1, 3);
	    push @{$start[$i]}, $i
	      unless $FORM{$c} || $c =~ /(TGA|TAG|TAA)/;
	}
    }
    # start codon
    push @codons, "ATG" if $FORM{'ATG'};
    push @codons, "GTG" if $FORM{'GTG'};
    push @codons, "TTG" if $FORM{'TTG'};
    push @codons, "ATT" if $FORM{'ATT'};
    push @codons, "CTG" if $FORM{'CTG'};
    push @codons, "ATG" unless $FORM{'ATG'} || $FORM{'GTG'} ||
				$FORM{'TTG'} || $FORM{'ATT'} || $FORM{'CTG'};
    for $codon (@codons) {
	$pos = -1;
	while (($pos = index($seq, $codon, $pos)) > -1) {
	    push @{$start[$pos % 3 +1]}, $pos + 1;
	    $pos++;
	}
    }
    # stop codon
    for $codon ("TGA","TAG","TAA") {
	$pos = -1;
	while (($pos = index($seq, $codon, $pos)) > -1) {
	    push @{$stop[$pos % 3 +1]}, $pos + 1;
	    $pos++;
	}
    }
    if ($FORM{incorf} eq "ON") { # virtual stop codon
	for $i (($seqlen-5) .. ($seqlen-3)) {
	    my $c = substr($seq, $i-1, 3);
	    push @{$stop[$i % 3 + 1]}, $i + 1
	      unless $FORM{$c} || $c =~ /(TGA|TAG|TAA)/;
	}
    }
    ($DEBUG > 1) and $NormalEndTime = time;

    # Complementary 
    ($DEBUG > 1) and $ComplStartTime = time;
    # start codon
    push @ccodons,"CAT" if $FORM{'ATG'};
    push @ccodons,"CAC" if $FORM{'GTG'};
    push @ccodons,"CAA" if $FORM{'TTG'};
    push @ccodons,"AAT" if $FORM{'ATT'};
    push @ccodons,"CAG" if $FORM{'CTG'};
    push @ccodons,"CAT"	unless $FORM{'ATG'} || $FORM{'GTG'} ||
				$FORM{'TTG'} || $FORM{'ATT'} || $FORM{'CTG'};
    if ($FORM{incorf} eq "ON") { # virtual start codon
	for $i (($seqlen-5) .. ($seqlen-3)) {
	    my $c = substr($seq, $i, 3);
	    $flag = 0;
	    for (@ccodons, "TCA", "CTA", "TTA") {
		$flag = 1 if /$c/;
	    }
	    push @{$cstart[&frameadjust((($i + 2) % 3) + 1)]}, $i + 3
	      unless $flag;
	  }
    }
    for $codon (@ccodons) {
	$pos = -1;
	while (($pos = index($seq, $codon, $pos)) > -1) {
	    push @{$cstart[&frameadjust((($pos + 2) % 3) + 1)]}, $pos + 3;
	    $pos++;
	}
    }
    # stop codon
    for $codon ("TCA","CTA","TTA") {
	$pos = -1;
	while (($pos = index($seq, $codon, $pos)) > -1) {
	    push @{$cstop[&frameadjust((($pos + 2) % 3) + 1)]}, $pos + 3;
	    $pos++;
	}
    }
    if ($FORM{incorf} eq "ON") { # virtual stop codon
	for $i (1 .. 3) {
	    my $c = substr($seq, $i, 3);
	    $flag = 0;
	    for (@ccodons, "TCA", "CTA", "TTA") {
		$flag = 1 if /$c/;
	    }
	    push @{$cstop[&frameadjust((($i + 2) % 3) + 1)]}, $i + 3
	      unless $flag;
	  }
    }

    for $frame (1 .. 3) {
	# sort by number
	for $i ("start","stop") {
	    @{$$i[$frame]} = sort { $a <=> $b } @{$$i[$frame]};
	}
	# sort by number (reverse)
	for $i ("cstart","cstop") {
	    @{$$i[$frame]} = sort { $b <=> $a } @{$$i[$frame]};
	}
    }

    ($DEBUG > 1) and $ComplEndTime = time;
    $DEBUG and $CookTime = time;
} # end of cook

sub drawimage {
    my($frame,$showflag,$pos,$i,$j,$x,$y,$x1,$x2,$y1,$y2);
    my $lm = 20;

    open(FLY,"| $flyprog -q -o $outpath/$outfilename");
    print FLY "new\n";
    print FLY "size $imagesize{'width'},$imagesize{'height'}\n";

    # color definition
    $red   = "255,0,0";
    $green = "0,127,0";
    $blue  = "0,0,255";
    $black = "0,0,0";
    $white = "255,255,255";
    if ($FORM{'color'} =~ /^c/io) {
	$BW = 0;
	@linecolor =  ("$red", "$green", "$blue");
	@clinecolor = ("$green", "$red", "$blue") if ($seqmod3 == 0);
	@clinecolor = ("$blue", "$green", "$red") if ($seqmod3 == 1);
	@clinecolor = ("$red", "$blue", "$green") if ($seqmod3 == 2);
    }
    else {
	$BW = 1;
	@linecolor =  ("$black", "$black", "$black" );
	@clinecolor = ("$black", "$black", "$black" );
	my $style0 = "$black,$black";
	my $style1 = "$black,$black,$black,$white,$white,$white";
	my $style2 = "$black,$white,$white";
	%linestyle =  ( 0 => "$style0", 1 => "$style1", 2 => "$style2" );
	%clinestyle = ( 0 => "$style1", 1 => "$style0", 2 => "$style2" )
	    if ($seqmod3 == 0);
	%clinestyle = ( 0 => "$style2", 1 => "$style1", 2 => "$style0" )
	    if ($seqmod3 == 1);
	%clinestyle = ( 0 => "$style0", 1 => "$style2", 2 => "$style1" )
	    if ($seqmod3 == 2);
    }

    print FLY "fill 1,1,$white\n";
    print FLY "string $black,$lm,5,medium,$TITLE $VERSION - $COPYRIGHT\n";
    print FLY "string $black,$lm,18,small,",
	      "FEMS Microbiol. Lett. 174:251-253 (1999)\n";
    print FLY "string $black,$lm,31,medium,",
	      "Target: $FORM{'label'} $seqlen bp; ",
	      "$avgc% G+C (dashed line)\n";
    print FLY "string $black,$lm,44,medium,",
	      "Window: $FORM{'window'}, ",
              "Step: $FORM{'step'}, ",
	      "Start codon [>]: @codons \n";
    print FLY "string $black,$lm,57,medium,",
	      "Minimum ORF: $FORM{'minorf'}, ",
	      "Date: $timestamp\n";

    # draw graph
    $x1 = $margin{'left'};
    $y1 = $margin{'top'};
    $x2 = $margin{'left'} + $graphsize{'width'};
    $y2 = $margin{'top'}  + $graphsize{'height'};
    print FLY "rect $x1,$y1,$x2,$y2,$black\n";
    # X axis
    for ($i = 100; $i < $seqlen; $i += 100) {
	$x1 = &xcoord($i);
	if (($i % 500) == 0) {
	    $y1 = &ycoord(4);
	}
	else {
	    $y1 = &ycoord(2);
	}
	$y2 = &ycoord(0);
	print FLY "line $x1,$y1,$x1,$y2,$black\n";
	if (($i % 1000) == 0) {
	    $x = $x1 - 10;
	    $y = $margin{'top'} + $graphsize{'height'} + 5;
	    print FLY "string $black,$x,$y,small,$i\n";
	}
    }
    # Y axis
    $x = $margin{'left'} - 18 ;
    $y = &ycoord(45);
    print FLY "stringup $black,$x,$y,small,G+C(%)\n";
    for ($i = 10; $i < 100; $i += 10) {
	$x1 = &xcoord(0);
	$y1 = &ycoord($i);
	if ($i == 50) {
	    $x2 = $x1 + 6;
	}
	else {
	    $x2 = $x1 + 3;
	}
	print FLY "line $x1,$y1,$x2,$y1,$black\n";
    }
    # draw average GC%
    $x1 = &xcoord(0);
    $x2 = &xcoord($seqlen);
    $y1 = &ycoord($avgc);
    print FLY "dline $x1,$y1,$x2,$y1,$black\n";
    # plot 3rd-letter GC%
    for $frame (0 .. 2) {
	print FLY "setstyle $linestyle{$frame}\n" if ($BW);
 	for $i (0 .. ($#{$gc[$frame]} - 1)) {
 	    $x1 = &xcoord((($i * 3) * $FORM{step}) + ($winlen / 2));
 	    $y1 = &ycoord($gc[$frame][$i]);
 	    $x2 = &xcoord(((($i+1) * 3) * $FORM{step}) + ($winlen / 2));
 	    $y2 = &ycoord($gc[$frame][$i+1]);
 	    print FLY "line $x1,$y1,$x2,$y2,@linecolor[$frame]\n";
 	}
	print FLY "killstyle\n" if ($BW);
    }

    # Start/Stop codon and ORF
    for $frame (0 .. 2) {
	# Normal Strand
	# frame label
	$x = 4;
 	$y = ($margin{'top'} - 80) + $frame * 12;
 	$c = @linecolor[$frame];
 	print FLY "string $c,$x,$y,small,",$frame+1,":\n";
	# start codon
	my $prevstop = 0;
	for $start (@{$start[$frame+1]}) {
	    $x = &xcoord($start) - 5;
	    $y = ($margin{'top'} - 80) + $frame * 12;
	    print FLY "string $c,$x,$y,medium,>\n"
	      if $FORM{substr $seq, $start-1, 3};
	    # ORF
	    print FLY "setstyle $linestyle{$frame}\n" if ($BW);
	    for $stop (@{$stop[$frame+1]}) {
		if ($stop > $start) {
		    last if (($stop - $start) <= $minorf);
		    push @{$orf[$frame+1]}, "$start:$stop";
		    if ($stop > $prevstop) {
			$x1 = &xcoord($start);
			$x2 = &xcoord($stop);
			$y += 6;
			print FLY "line $x1,$y,$x2,$y,$c\n";
			$prevstop = $stop;
		    }
		    last;			
		}
	    }
	    print FLY "killstyle\n" if ($BW);
	}
	# stop codon
	for $stop (@{$stop[$frame+1]}) {
	    $x = &xcoord($stop) - 3;
	    $y = ($margin{'top'} - 80) + $frame * 12;
	    print FLY "string $c,$x,$y,medium,|\n"
	      if substr($seq, $stop-1, 3) =~ /(TGA|TAG|TAA)/;
	}
	# Complementary Strand
	# frame label
	$x = 4;
	$y = ($margin{'top'} - 40) + $frame * 12;
	$c = @clinecolor[$frame];
	print FLY "string $c,$x,$y,small,",$frame+1,":\n";
	# strat codon
	my $showflag = 0;
	my $cdn = substr($seq, $cstart[$frame+1][0]-3, 3);
	for (@ccodons) {
	    $showflag = 1 if /$cdn/;
	}
	my $prevstop = $seqlen;
	for $start (@{$cstart[$frame+1]}) {
	    $x = &xcoord($start);
	    $y = ($margin{'top'} - 40) + $frame * 12;
	    $showflag ? print FLY "string $c,$x,$y,medium,<\n"
		: ($showflag = 1);
	    # ORF
	    print FLY "setstyle $clinestyle{$frame}\n" if ($BW);
	    for $stop (@{$cstop[$frame+1]}) {
		if ($stop < $start) {
		    last if (($start - $stop) <= $minorf);
		    push @{$corf[$frame+1]}, "$start:$stop";
		    if ($stop < $prevstop) {
			$x1 = &xcoord($start);
			$x2 = &xcoord($stop);
			$y += 6;
			print FLY "line $x1,$y,$x2,$y,$c\n";
			$prevstop = $stop;
		    }
		    last;
		}
	    }
	    print FLY "killstyle\n" if ($BW);
	}
	# stop codon
	for $stop (@{$cstop[$frame+1]}) {
	    $x = &xcoord($stop) - 2;
	    $y = ($margin{'top'} - 40) + $frame * 12;
	    print FLY "string $c,$x,$y,medium,|\n"
	      if substr($seq, $stop-3, 3) =~ /(TCA|CTA|TTA)/;
	}
    }

    print FLY "interlace\n";
    close(FLY);
    $DEBUG and $DrawTime = time;
} # end of drawimage

sub resultpage {
    my($frame,$array);
    print <<"HTML";
Content-Type: text/html

<title>Result</title>
<body bgcolor="$bgcolor">
HTML


    print <<"HTML";
<a href="$HelpDoc#clickmap">
Click to show sequence of ORF</a>.<br>
<form action="$ENV{SCRIPT_NAME}" method="POST" target="feature">
<input type="IMAGE" src="$outurl/$outfilename" border="0">
<input type="HIDDEN" name="sequence" value="$seq">
<input type="HIDDEN" name="label" value="$FORM{label}">
<input type="HIDDEN" name="width" value="$graphsize{width}">
HTML

    for $i ("orf","corf") {
	for $frame (1 .. 3) {
	    $array = join("", $i, $frame);
	    my $orfs;
	    for $j (@{$$i[$frame]}) { $orfs .= "$j "; }
	    print "<input type=\"HIDDEN\" name=\"$i$frame\" value=\"$orfs\">\n";
	}
    }
    print "</form>\n";

    print <<"HTML";
<font size="-1">
Graph plotting done with
<a href="http://www.unimelb.edu.au/fly/fly.html">Fly</a>,
by Martin Gleeson.

<form method="POST" action="$ENV{'SCRIPT_NAME'}">
<input type="HIDDEN" name="remove" value="$outfilename">
Your result (<a href="$outurl/$outfilename">$outfilename</a>)
still remains on our server.
Before leaving from this page,
click <input type="SUBMIT" value="Remove"> 
button to remove it (highly recommended).
</form>
</font>
HTML

    print <<"HTML";
<form method="POST" name="orftab" action="$ENV{SCRIPT_NAME}" target="feature">
<input type="SUBMIT" name="feature" value="Show Feature">
<input type="RESET">
<input type="HIDDEN" name="label" value="$FORM{label}">
<input type="HIDDEN" name="sequence" value="$seq">
<table border="1" bgcolor="#fdfdfd" cellpadding="3">
<tr><td colspan="4" align="center" bgcolor="#f5dcb3"><b>Normal</b>
<tr><td align="center">Frame
    <td align="center">Start codon<br>(@codons)
    <td align="center">Stop  codon<br>(TGA TAG TAA)
    <td align="center">ORF<br>(Start:Stop)
HTML

for $frame (1 .. 3) {
    print "<tr><td align=\"center\">$frame\n";
    for $item ("start","stop") {
	print "    <td valign=\"top\">@{$$item[$frame]}<br>\n";
    }
    print "    <td valign=\"top\">\n";
    for $i (@{$orf[$frame]}) {
	print "\t<input type=\"RADIO\" name=\"orf\" value=\"$i:$frame\" ",
		"onClick=\"document.orftab.feature.click()\">$i\n";
    }
    print "<br>\n";
}

print <<"HTML";
<tr><td colspan="4" align="center" bgcolor="#f5dcb3"><b>Complementary</b>
<tr><td align="center">Frame
    <td align="center">Start codon<br>(@codons)
    <td align="center">Stop  codon<br>(TGA TAG TAA)
    <td align="center">ORF<br>(Start:Stop)
HTML

    for $frame (1 .. 3) {
        print "<tr><td align=\"center\">$frame\n";
	for $item ("cstart","cstop") {
	    print "    <td valign=\"top\">@{$$item[$frame]}<br>\n";
	}
	print "    <td valign=\"top\">\n";
	for $i (@{$corf[$frame]}) {
	    print "\t<input type=\"RADIO\" name=\"orf\" value=\"$i:$frame\" ",
		"onClick=\"document.orftab.feature.click()\">$i\n";
	}
	print "<br>\n";
    }

    print <<"HTML";
</table><br>
<font size="-1">
Numbers denote the 1st-letter position of each codon.
</font>
</form>
HTML

    # DEBUG messages
    if ($DEBUG) {
	$EndTime = time;
	print  "Total=",$EndTime-$StartTime;
	print " [", int($seqlen/($EndTime-$StartTime)), " bases/sec]: "; 
	print  "Cook=",$CookTime-$StartTime;
	if ($DEBUG > 1) {
	    print "(";
	    print "AvGC=",$AvGCEndTime-$AvGCStartTime,"/";
	    print "3rdGC=",$ThirdGCEndTime-$ThirdGCStartTime,"/";
	    print "Nrml=",$NormalEndTime-$NormalStartTime,"/";
	    print "Cmpl=",$ComplEndTime-$ComplStartTime;
	    print ")";
	}
	print "/Draw=",$DrawTime-$CookTime;
    }
    if ($LOGGING) {
	open(LOG, ">>$outpath/frameplot.log");
	print LOG "VERSION: $VERSION\n";
	print LOG "REMOTE_HOST: $ENV{REMOTE_HOST}\n";
	print LOG "REMOTE_ADDR: $ENV{REMOTE_ADDR}\n";
	print LOG "HTTP_USER_AGENT: $ENV{HTTP_USER_AGENT}\n";
	print LOG "TIME: $timestamp\n";
	print LOG "UTC: ",time,"\n";
	print LOG "SEQ_LEN: $seqlen\n";
	print LOG "STEP: $FORM{'step'}\n";
	print LOG "SEQ_LABEL: $FORM{'label'}\n";
	print LOG "OUT_IMAGE: $outfilename\n";
	$DEBUG and
	    print LOG "RATE: ",
	        int($seqlen/($EndTime-$StartTime))," base/sec\n";
	print LOG "\n";
	close(LOG);
    }
} # end of resultpage

sub removeresult {
    unlink "$outpath/$FORM{remove}";
    print <<"HTML";
Content-Type: text/html

<title>Remove Result</title>
<body bgcolor="$bgcolor">
<h2>Your result (<a href="$outurl/$FORM{remove}">$FORM{'remove'}</a>)
    was removed.</h2>

After clearing the memory cache of your browser,
you can confirm the removal of your data by clicking above link.

<h3><a href="$ENV{'SCRIPT_NAME'}">[Back to the main page]</a></h3>
HTML
}

sub findorf {
    my($frame, $pos) = @_;
    my($start, $end, $hit);
    if (1 <= $frame && $frame <= 3) { # Normal
	my @array = split /\s+/, $FORM{"orf$frame"};
	for (reverse @array) {
 	    ($start, $end) = split /:/;
	    if ($start <= $pos && $pos <= $end) {
		$hit = 1;
		last;
	    }
	}
    }
    elsif (4 <= $frame && $frame <= 6) { # Complementary
	$frame = $frame - 3;
	my @array = split /\s+/, $FORM{"corf$frame"};
	for (reverse @array) {
	    ($start, $end) = split /:/;
	    if ($start >= $pos && $pos >= $end) {
		$hit = 1;
		last;
	    }
	}
    }

    $hit ? return "$start:$end:$frame" : return 0;
}

sub feature {
    my($start, $end, $frame) = @_;
    my($nucl, $peptide, $nucheader, $pepheader, $nuclen, $peplen);

    print "Content-Type: text/html\n\n";
    print "<title>Featuers</title>\n";
    print "<body bgcolor=\"$bgcolor\">\n";

    unless ($frame) {
	print "No ORF here.";
	exit;
    }

    if ($start < $end) {
	$nucl = substr($seq, $start-1, $end-$start+3);
	$nuclen = length($nucl);
	$nucheader = ">$FORM{label} f$frame ($start. ." . ($end+2)
	    . ")\t" . $nuclen . "bp\t$today";
	$peptide = substr($seq, $start-1, $end-$start);
	$peptide = &translate($peptide);
	$peplen = length($peptide);
	$pepheader = ">$FORM{label} f$frame ($start. ." . ($end-1)
	    . ")\t" . $peplen . " aa\t$today";
    }
    elsif ($start > $end) {
	$nucl = substr($seq, $end-3, $start-$end+3);
	$nucl = &complement($nucl);
	$nuclen = length($nucl);
	$nucheader = ">$FORM{label} f${frame}c ($start. ." 
	    . ($end-2) . ")\t" . $nuclen . " bp\t$today";
	$peptide = substr($seq, $end, $start-$end);
	$peptide = &complement($peptide);
	$peptide = &translate($peptide);
	$peplen = length($peptide);
	$pepheader = ">$FORM{label} f${frame}c ($start. ." . 
	    ($end+1) . ")\t" . $peplen . " aa\t$today";
    }

    # base composition
    %basecomposit = &basecomposit($nucl);
    # 3rd letter GC%
    $gc3rd = &gc3rd($nucl);

    # features
    print "<h2 align=\"left\">FEATURES</h2>\n";
    print "<table>\n";
    print "<tr><td>3rd-Letter GC:<td>$gc3rd%\n";
    print "<tr><td>Base Composition:<td>$basecomposit{A} A $basecomposit{C} C $basecomposit{G} G $basecomposit{T} T\n";
    print "</table>\n";

    print "<p>\n<table cellpadding=\"5\">\n";
    # nucleotide
    print "<tr><td bgcolor=\"#f5dcb3\">";
    print "<pre>\n", &fasta($nucl, $nucheader),"</pre>\n";
    print "<tr><td>";
    &NCBI_BLAST(&fasta($nucl, $nucheader), "nucleotide");
    # peptide
    print "<tr><td bgcolor=\"#f5dcb3\">";
    print "<pre>\n", &fasta($peptide, $pepheader), "</pre>\n";
    print "<tr><td>";
    &NCBI_BLAST(&fasta($peptide, $pepheader), "peptide");
    print "</table>";

    print "<hr>\n";
    print "<font size=\"-1\">\n";
    print "<a href=\"http://www.ncbi.nlm.nih.gov/BLAST/newblast.html\">";
    print "What is the BLAST 2.0</a>\n";
    print "</font>\n";
} # end of feature

sub basecomposit {
    my $nucl = $_[0];
    my %cmpst;
    $cmpst{A} = $nucl =~ tr/A/A/;
    $cmpst{C} = $nucl =~ tr/C/C/;
    $cmpst{G} = $nucl =~ tr/G/G/;
    $cmpst{T} = $nucl =~ tr/T/T/;
    return %cmpst;
}

sub gc3rd {    # 3rd letter GC%
    my $nucl = $_[0];
    my $nuclen = length($nucl);
    my($c, $i);
    for ($i = 2; $i < $nuclen; $i += 3) {
	$_ = substr $nucl, $i, 1;
	$c++ if /[GC]/o;
    }
    return sprintf "%4.1f", ($c / ($nuclen / 3)) * 100;
}

sub complement {
    my $sequence = $_[0];
    $sequence =~ tr [AGCT]
                    [TCGA];
    my $complement = reverse $sequence;
    return $complement;
}

sub translate {
    my(@peptide,$i,$a);
    my $temp = join "", @_;
    return "Sequence is not multiples of 3"
	unless ((length($temp) % 3) == 0);
    my %univcode = (
		 TTT => "F", TCT => "S", TAT => "Y", TGT => "C",
		 TTC => "F", TCC => "S", TAC => "Y", TGC => "C",
		 TTA => "L", TCA => "S", TAA => "*", TGA => "*",
		 TTG => "L", TCG => "S", TAG => "*", TGG => "W",
		 CTT => "L", CCT => "P", CAT => "H", CGT => "R",
		 CTC => "L", CCC => "P", CAC => "H", CGC => "R",
		 CTA => "L", CCA => "P", CAA => "Q", CGA => "R",
		 CTG => "L", CCG => "P", CAG => "Q", CGG => "R",
		 ATT => "I", ACT => "T", AAT => "N", AGT => "S",
		 ATC => "I", ACC => "T", AAC => "N", AGC => "S",
		 ATA => "I", ACA => "T", AAA => "K", AGA => "R",
		 ATG => "M", ACG => "T", AAG => "K", AGG => "R",
		 GTT => "V", GCT => "A", GAT => "D", GGT => "G",
		 GTC => "V", GCC => "A", GAC => "D", GGC => "G",
		 GTA => "V", GCA => "A", GAA => "E", GGA => "G",
		 GTG => "V", GCG => "A", GAG => "E", GGG => "G",
		 );

#    push @peptide, "M";
#    for ($i = 3; $i < length($temp); $i += 3) {
    for ($i = 0; $i < length($temp); $i += 3) {
	if ($univcode{substr($temp, $i, 3)}) {
	    $a = $univcode{substr($temp, $i, 3)};
	}
	else {
	    $a = "X";
	}
	push @peptide, $a;
    }
    return join "", @peptide;
}

sub fasta { # FASTA format
    my($sequence, $header) = @_;
    my @chars = split('',$sequence);
    my $result .= "$header\n";
    my $counter = 0;
    for $char (@chars) {
	$result .= "$char";
	$counter++;
	if ($counter == 50) {	# 50 column per line
	    $counter = 0;
	    $result .= "\n";
	}
    }
    $result .= "\n";
    return $result;
}

sub xcoord {
    my $x = $margin{left} + ($graphsize{width} / $seqlen * $_[0]) ;
    return $x;
}

sub ycoord {
    my $y = ($margin{top} + $graphsize{height}) 
		- (($graphsize{height} / 100) * $_[0]) ;
    return $y;
}

sub xy2pos {
    my($x, $y) = @_;

    # y to frame
    my $frame = ($y - ($margin{'top'} - 80)) / 12;
    $frame = int($frame+1);
    # x to nucleotide position
    my $pos = ($x - $margin{left}) / ($graphsize{width} / $seqlen);
    $pos = int($pos);

    return ($frame, $pos);
}

sub frameadjust {
    if ($seqmod3 == 0) {
	return 3 if $_[0] == 1;
	return 2 if $_[0] == 2;
	return 1 if $_[0] == 3;
    }
    elsif ($seqmod3 == 1) {
	return 1 if $_[0] == 1;
	return 3 if $_[0] == 2;
	return 2 if $_[0] == 3;
    }
    elsif ($seqmod3 == 2) {
	return 2 if $_[0] == 1;
	return 1 if $_[0] == 2;
	return 3 if $_[0] == 3;
    }
}

sub cgiparse { # parse CGI parameters
    my(%form,$name,$value,@pairs);
    @pairs = split(/&/,$_[0]);
    for (@pairs) {
	($name, $value) = split /=/;
	$value =~ tr/\+/ /;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	$form{$name} = $value;
    }
    return %form;
}


sub stop {
    unlink("$outpath/$outfilename");
    exit 1; 
}

sub NCBI_BLAST {
    my $URLBASE = "http://www.ncbi.nlm.nih.gov";
    my $progs;
    if ($_[1] =~ /^n/io) {
	$progs = "<option slected> blastn\n<option> blastx\n<option> tblastx";
    }
    else {
	$progs = "<option selected> blastp\n<option> tblastn";
    }
print <<"HTML";
<form method="POST" action="$URLBASE/cgi-bin/BLAST/nph-newblast">
<input type="SUBMIT" value="Search">
with
<a href="$URLBASE/BLAST/blast_program.html">Program</a>
<select name = "PROGRAM">
$progs
</select>
against
<a href="$URLBASE/BLAST/blast_databases.html">Database</a>
<select name = "DATALIB">
  <option value="nr"> nr
  <option value="month"> month
  <option value="swissprot"> swissprot
  <option value="dbest"> dbest
  <option value="dbsts"> dbsts
  <option value="est_mouse"> mouse ests
  <option value="est_human"> human ests
  <option value="est_others"> others ests
  <option value="pdb"> pdb
  <option value="patents"> patents
  <option value="vector"> vector
  <option value="kabat"> kabat
  <option value="mito"> mito
  <option value="alu"> alu
  <option value="epd"> epd
  <option value="yeast"> yeast
  <option value="ecoli"> ecoli
  <option value="gss"> gss
  <option value="htgs"> htgs
</select>
<br>
<input type="CHECKBOX" name="UNGAPPED_ALIGNMENT" value="is_set">
ungapped alignment.

<input type="CHECKBOX" name="FSET" value="isset">
<a href="$URLBASE/BLAST/filtered.html">
filtered</a> for low complexity regions.
<input type="HIDDEN" name="OVERVIEW" value="isset">
<input type="HIDDEN" name="INPUT_TYPE" value="Sequence in FASTA format">
<input type="HIDDEN" name="SEQUENCE" value="$_[0]">
</form>
HTML
}

sub mainpage {
    print <<"HTML";
Content-Type: text/html

<title>$TITLE $VERSION</title>
<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">
<body bgcolor="$bgcolor">
<h1 align="center">
  <a name="top">$TITLE $VERSION</a><a href="/~jun/research/frameplot/">*</a>
</h1>
<p align="center">
$DATE<br>
$COPYRIGHT<br>
<font color="#ff0000">CAUTION:
No warranty! ``USE AT YOUR OWN RISK''.</font>
</p>

<form method="POST" action="$ENV{'SCRIPT_NAME'}">
<table cellpadding="3" width="100%" border="0">
  <tr align="center">
  <td colspan="4">
  <a href="$HelpDoc#sequence">
  <b>DNA sequence</b></a>
  (DON'T include comments. Digits and spaces are ignored.):
  <textarea name="sequence" rows="10" cols="70"></textarea><br>
  <tr align="left">
  <td><input type="submit" value="Cookin'">
      <input type="reset"  value="Reset"><br>
  <td colspan="3">
  This may take a little time to run
  (200-2000 base/sec depends on ``step size'').
  <tr align="center" bgcolor="#ccccff">
  <td colspan="4">OPTIONAL PARAMETERS
  <tr align="center" valign="top">
  <td><a href="$HelpDoc#window">
  <b>Window size:</b></a><br>
  <select name="window">
    <option value="10">  10 codons
    <option value="20">  20 codons
    <option value="30">  30 codons
    <option value="40" selected> 40 codons
    <option value="50">  50 codons
    <option value="60">  60 codons
    <option value="70">  70 codons
    <option value="80">  80 codons
    <option value="90">  90 codons
    <option value="100"> 100 codons
  </select>
  <td colspan="3">
  <a href="$HelpDoc#startcodon">
  <b>Start codon:</b></a><br>
  <input type="checkbox" name="ATG" checked>ATG
  <input type="checkbox" name="GTG">GTG
  <input type="checkbox" name="TTG">TTG
  <input type="checkbox" name="CTG">CTG
  <input type="checkbox" name="ATT">ATT
  <tr align="center" valign="top">
  <td>
  <a href="$HelpDoc#stepsize">
  <b>Step size:</b></a><br>
  <select name="step">
    <option value="1">     1 codon
    <option value="5" selected>     5 codons
    <option value="10">   10 codons
    <option value="30">   25 codons
    <option value="50">   50 codons
    <option value="100"> 100 codons
  </select>
  <td><a href="$HelpDoc#minorf">
  <b>Minimum ORF size:</b></a><br>
  <select name="minorf">
    <option value="10">   10 codons
    <option value="20" selected>   20 codons
    <option value="30">   30 codons
    <option value="40">   40 codons
    <option value="50">   50 codons
    <option value="100"> 100 codons
  </select>
  <td><a href="$HelpDoc#incorf">
  <b>Incomplete ORF:</b></a><br>
  <select name="incorf">
    <option value="ON" selected>  ON
    <option value="OFF"> OFF
  </select>
  <td><a href="$HelpDoc#imagewidth">
  Image width:</a><br>
  <select name="width">
    <option value="auto"> Auto
    <option value="300">   300 dots
    <option value="400">   400 dots
    <option value="500">   500 dots
    <option value="750">   750 dots
    <option value="1000"> 1000 dots
    <option value="2000"> 2000 dots
    <option value="3000"> 3000 dots
    <option value="4000"> 4000 dots
    <option value="5000"> 5000 dots
  </select>
  <tr valign="top">
  <td align="center">
  <a href="$HelpDoc#color">
  Image color:</a><br>
  <select name="color">
    <option value="color"> Color
    <option value="blackandwhite"> Black &amp; White
  </select>
  <td align="left" colspan="3">
  <a href="$HelpDoc#seqlabel">
  Sequence label</a> (sample#, sequence ID, etc.; optional):<br>
  <input type="text" size="30" name="label">
</table>
</form>

<hr>
Comments are very much appreciated to: <a href="mailto:$AUTHOR">$AUTHOR</a>
HTML

print <<"HTML";
<p>
<font size="-1">
<h4><a name="history">Change history</a></h4>
<dl>
  <dt> Version 2.3 (1999/6/20):
  <dd> ORF table with RADIO button.
       FEATURES in a new window.
       Improved ORF-drawing routine.
       "S" treated as "G/C".
  <dt> Version 2.2.1 (1999/1/13):
  <dd> bug fix.
  <dt> Version 2.2 (1999/1/11):
  <dd> Set max. imagewidth to 7000.
       Recognizing incomplete ORF (default ON).
  <dt> Version 2.1 (1998/4/26):
  <dd> Black &amp; white mode by using of 
       <a href="http://www.unimelb.edu.au/fly/fly.html">fly</a> v.1.6.0
  <dt> Version 2.0 (1998/2/27):
  <dd> Clickable map (really great!).
       Gateway to the NCBI BLAST server.
       Step size option (fast analysis).
       Recognizing CTG as a start codon.
       Auto image width.
       Rewrote indexing loops.
  <dt> Version 1.2 (1997/6/15):
  <dd> Changed the way of selecting start codon.
       Recognizing ATT as a start codon.
  <dt> Version 1.1 (1997/6/10):
  <dd> Added complementary strand analysis function.
       Improved average G+C% routine.
       Improved 3rd-letter G+C% routine (30% speed up).
  <dt> Version 1.0 (1997/3/17):
  <dd> Replaced \$cgipath with \$ENV{'SCRIPT_NAME'}
  <dt> Version 0.7 (1997/1/22):
  <dd> Listing open reading frame.
       Added minimum ORF size option.
       Fixed ATTG bug.
  <dt> Version 0.6 (1996/12/28):
  <dd> Recognizing both ATG and GTG as start codons.
       Showing open reading frame.
  <dt> Version 0.5 (1996/12/15):
  <dd> Recognizing (A)TTG as a start codon.
       Changed internal data structure (about 2-fold faster).
  <dt> Version 0.4 (1996/12/13):
  <dd> Improved start/stop codon searching routine
       (over 100-fold faster than the original).
  <dt> Version 0.3 (1996/12/10):
  <dd> Recognizing GTG as a start codon.
       20-30% faster than version 0.2 (Is that true?:-).
       Interlaced GIF.
  <dt> Version 0.2 (1996/12/9):
  <dd> Added data removing function,
       START/STOP codon table,
       sequence label option,
       and image width option.
  <dt> Version 0.1 (1996/12/8):
  <dd> initial release. 
       Only recognizes "ATG" as start codon.
       Not available complementary strand analysis.
</dl>
</font>
HTML

    if ($LOGGING && $ENV{HTTP_REFERER}) {
	open(WHERE,">>$outpath/fromwhere.log");
	print WHERE "$ENV{HTTP_REFERER}\n";
	close(WHERE);
    }
} # end of mainpage

__END__