#!/usr/bin/perl -- 	# -*- C -*-
# T.Hubbard
# 26/7/94
# extended 4/8/94
# bug fixed 16/8/94 [re should accept]
# extended 24/3/95
# -colour's active chain
# -centres on region

# derivative of rsgen.cgi

# creates command string to send to rasmol to display
# the backbone of a protein structure

# $xx{'pd'} is expected to be a valid 4 digit pdb code
#    i.e. 1tim
#
# $xx{'pc'} is expected either to be empty or
#           to contain a single protein chain letter
#    i.e. A or A,B
#
# $xx{'pr'} is expected either to be empty or
#           to contain a single region of sequence
#    i.e. 1-10 or A:1-10 or A:1-10,A:12-20
#
# $xx{'s1'} is expected either to be empty or
#           to contain a single region of sequence
#    i.e. 1-10 or A:1-10 or A:1-10,A:12-20

# only expect pd || (pd && pc) || (pd && pr )

require 5.002;
require './cgi-lib.pl';
#$debug_mode = 0;

# For printing
$Date = "\$Date";
$End = "\$";

#unless($debug_mode){

 MAIN:
{
    &ReadParse(*in);
    $ret = &rsgen(%in);
    if($in{"chime"}==1){
      $ret=~s/\n/;/g;
      $ret=~s/\|\|/or/g;
      ($id,$script)=($ret=~/^echo.*load pdb(\w{4})\.ent;(.*)$/);
      &SendChime($id,$script);
    }else{
      print "Content-type: application/x-rasmol\n\n";
      print $ret;
    }
}

#}else{ 

# bugs

#  ($xx{'pd'},$xx{'pc'},$xx{'pr'})=@ARGV;
#  print "PD=$xx{'pd'}\nPC=$xx{'pc'}\nPR=$xx{'pr'}\n\n";
#  $ret = &rsgen(%xx);
#  print "$ret\n";

#}

sub rsgen {
    local (%xx) = @_;
    local($prot,$sub,$region,$ret,$chain);
    undef $chain;
    $prot=$xx{'pd'};
    $prot=~y/A-Z/a-z/;

# rasmol instruction to load pdb file, with tags to allow
# local substitution for directory and file extension

  $ret .= "echo The rasmol-scop interface.\n";
  $ret .= "echo  See scop help for coloring information.\necho\n";
  $ret .= "echo Loading PDB Entry $prot...\n";
  $ret .= "zap\nload pdb$prot.ent\n";

# pc = protein chains (really a subset of pr and should be merged)

    if($xx{'pc'}){
	undef $region;
        $sub=$xx{'pc'};
	$sub=~y/a-z/A-Z/;

# for each chain, specification is *X 
# separated by ||

	foreach $sub (split(/,/,$sub)){
	    $region.="\*:$sub || ";
	}

# 3 chops remove trailing "|| "

	chop $region;
	chop $region;
	chop $region;
	$chain=$region;
    }

# region

    if($xx{'pr'}){
	undef $chain;
	undef $region;
	$sub=$xx{'pr'};
	$sub=~y/a-z/A-Z/;
	foreach $sub (split(/,/,$sub)){

# if length=1 must be a chain -> add a *

	    if($sub=~/^(\w)$/){
		$region.="\*:$1 || ";
		$chain.="\*:$1 || ";
		
# if $sub contains a ':', make into an && statement

	    }elsif($sub=~/^(\w):([\d-]+)$/){
		$region.="\(\*:$1 && $2\) || ";
		$chain.="\*:$1 || ";
		
# if region defined with no chain, by definition, chain context is all

	    }elsif($sub=~/^([\d-]+)$/){
		$chain="all || ";
		$region.="$sub || ";
	    }
	}
	chop $region;
	chop $region;
	chop $region;
	chop $chain;
	chop $chain;
	chop $chain;
    }

# define segments of different colours
# may be continous (different blast HSP's) or fragmentary (conservation/
# overlap colouring)
    undef $seg;
    if($xx{'s0'}){
	$seg[0]=&segn($xx{'s0'});
	$seg=1;
    }
    if($xx{'s1'}){
	$seg[1]=&segn($xx{'s1'});
	$seg=1;
    }
    if($xx{'s2'}){
	$seg[2]=&segn($xx{'s2'});
	$seg=1;
    }
    if($xx{'s3'}){
	$seg[3]=&segn($xx{'s3'});
	$seg=1;
    }
    if($xx{'s4'}){
	$seg[4]=&segn($xx{'s4'});
	$seg=1;
    }
    if($xx{'s5'}){
	$seg[5]=&segn($xx{'s5'});
	$seg=1;
    }
    if($xx{'s6'}){
	$seg[6]=&segn($xx{'s6'});
	$seg=1;
    }

# set colour scheme
# define's zero...n
    if($xx{'col'}){
# hack for old files with wrong number of colours (!!)
# will probably have to be deleted...
      if($xx{'col'}=~/^magenta/){
        $n=1;
      }else{
        $n=0;
      }
      foreach $col (split(/,/,$xx{'col'})){
	$col[$n++]=$col;
      }
    }else{
      $col[0]='blue';
      $col[1]='red';
      $col[2]='redorange';
      $col[3]='orange';
      $col[4]='yellow';
      $col[5]='green';
      $col[6]='purple';
    }

# rest is region of interest, which may be chain or region
# chain is whole chain of region of interest

# global colour is violet:

    $ret.="select not (nucleic)\ncolour violet\n";
#    $ret.="define upr (not (nucleic))\nselect upr\ncolour violet\n";

# backbone for whatever is target (all, chain or region)

    $ret.="wireframe off\nbackbone 80\n";

# colour of chain(s) selected is redorange

    if($chain){
	$ret.="define uch $chain\nselect uch\ncolour redorange\n";
    }else{
#        $ret.="define uch upr\n";
    }

# if a region has been defined, centre on it

    if($region){
	$ret.="define ure $region\nselect ure\ncentre $region\n";
    }else{
#        $ret.="define ure uch\n";
    }

    if($seg){
        $ret.="colour $col[0]\n";
    }else{
        $ret.="colour structure\n";
    }

# do segment if required

    for($i=1;$i<=$#seg;$i++){
      if(defined($seg[$i])){
        &segout($seg[$i],$col[$i]);
      }
    }
# do segment 0 last, since if it exist (background) its an overwrite...
    &segout($seg[0],$col[0]) if defined($seg[0]);

# any nucleic that is part of target should be wireframe

    if($region){
        $ret.="select nucleic && ($region)\nbackbone off\nwireframe on\ncolour shapely\n";
    }else{
        $ret.="select nucleic\nbackbone off\nwireframe on\ncolour shapely\n";
    }

# global: non solvent hetero's are cpk

    $ret.="set hetero on\nselect hetero && not solvent\ncolour cpk\ncpk on\n";

# if there was a region, make sure rest ends up backbone

    if($region){
        $ret.="select not ($region)\nbackbone 80\n";
    }

# end with correct state for subsequent global user operations

    $ret.="select all\n";
#    open(TMP,">/var/tmp/rsgen.log");
#    print TMP "$ret\n";
#    close(TMP);
    return $ret;
}

# build a string for each colour definition
sub segn{
    local($sub)=@_;
    local($seg,$len);
    undef $seg;
    $sub=~y/a-z/A-Z/;
    $len=0;
    foreach $sub (split(/,/,$sub)){

# if $sub contains a ':', make into an && statement

	if($sub=~/^(\w):([\d-]+)$/){
	    $tmp="\(\*:$1 && $2\) || ";
            $len+=length($tmp);
            $seg.=$tmp;
		
# if region defined with no chain, by definition, chain context is all

	}elsif($sub=~/^([\d-]+)$/){
	    $tmp="$sub || ";
            $len+=length($tmp);
            $seg.=$tmp;
	}

# lines can easily get too long for normal string handling
# insert BRK, which is recognised in segout to split the lines

        if($len>70){
            $seg=~s/^(.*)\|\| $/\1BRK/;
            $len=0;
        }
    }
    chop $seg;
    chop $seg;
    chop $seg;
    return $seg;
}

# select and colour...
sub segout{
    local($seg,$col)=@_;
    foreach $segf (split(/ BRK/,$seg)){
        $ret.="select $segf\ncolour $col\n";
    }
}

sub SendChime {
  my ($id,$script) = @_;
  my ($opts);

  my $pdbsource = "http://scop.mrc-lmb.cam.ac.uk/scop";

  print &PrintHeader;
  print "<head><title>SCOP: Chemscape Chime Viewer</title></head>";
  print &ScopHeader;
print <<ENDOFTEXT;
<p><b><a href="chime-help.html">Chime</a> display of PDB entry $id
ENDOFTEXT
print <<ENDOFTEXT if($in{pc});
, chain $in{pc}
ENDOFTEXT
print <<ENDOFTEXT if($in{pr});
, region $in{pr}
ENDOFTEXT
print <<ENDOFTEXT;
:</b><br>
ENDOFTEXT
print <<ENDOFTEXT if($in{pc} || $in{pr});
 Click to display: 
ENDOFTEXT
# http://ind2.mrc-lmb.cam.ac.uk/work/uch.spt
# http://ind2.mrc-lmb.cam.ac.uk/work/ure.spt
# http://ind2.mrc-lmb.cam.ac.uk/work/all.spt
# <embed src="$pdbsource/pdb.cgi?id=$id;disp=mc" name="PDB$id" height=400 width=400 script="$script">
print <<ENDOFTEXT if($in{pc} || $in{pr}=~/:/);
 <embed type="application/x-spt" src="spt.cgi?com=pc" target="PDB$id" width=15 height=15 align=absmiddle button="push"> chain only, 
ENDOFTEXT
print <<ENDOFTEXT if($in{pr});
 <embed type="application/x-spt" src="spt.cgi?com=pr" target="PDB$id" width=15 height=15 align=absmiddle button="push"> region only, 
ENDOFTEXT
print <<ENDOFTEXT if($in{pc} || $in{pr});
 <embed type="application/x-spt" src="spt.cgi?com=all" target="PDB$id" width=15 height=15 align=absmiddle button="push"> whole structure.<br>
ENDOFTEXT

# Raphael Leplae lp1@sanger.ac.uk - 19 Dec 2000:
# replaced pdb.cgi with http://scop.mrc-lmb.cam.ac.uk/scop/pdb.cgi

print <<ENDOFTEXT;
<hr>
<center>
 <embed type="application/x-spt" src="$pdbsource/pdb.cgi?id=$id;disp=mc" name="PDB$id" height=600 width=600 script="$script">
<br><b>You need to have the Chime Plug-in <a href="chime-help.html#install">installed</a> for a structure to be displayed</b><br>
</center>
ENDOFTEXT
  print &ScopFooter;
}
  
# <h2>Sorry</h2><br>

sub ScopHeader {
  return <<ENDOFTEXT;
<body>
<i>Structural Classification of Proteins</i><HR>
<a href="index.html"><img src="I/r.scop.gif" alt="home "></a><a href="http://scop.mrc-lmb.cam.ac.uk/scop/mail.cgi"><img src="I/r.mail.gif" alt="mail "></a><a href="help.html"><img src="I/r.ques.gif" alt="help "></a>
<br>
ENDOFTEXT
}

sub ScopFooter {
  return <<ENDOFTEXT;
<hr>
<address>Copyright  &#169; 1994-2009
  The scop authors / scop\@mrc-lmb.cam.ac.uk</address> 
June 2009
</body>
ENDOFTEXT
}