[Bio] / FigWebServices / subsys_hope.cgi Repository:
ViewVC logotype

View of /FigWebServices/subsys_hope.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (download) (annotate)
Mon Dec 5 19:12:12 2005 UTC (13 years, 11 months ago) by olson
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, caBIG-05Apr06-00, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0806, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2011_0928, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, caBIG-13Feb06-00, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24, rast_rel_2008_08_07, HEAD
Changes since 1.1: +17 -0 lines
add license words

# -*- perl -*-
#
# Copyright (c) 2003-2006 University of Chicago and Fellowship
# for Interpretations of Genomes. All Rights Reserved.
#
# This file is part of the SEED Toolkit.
# 
# The SEED Toolkit is free software. You can redistribute
# it and/or modify it under the terms of the SEED Toolkit
# Public License. 
#
# You should have received a copy of the SEED Toolkit Public License
# along with this program; if not write to the University of Chicago
# at info@ci.uchicago.edu or the Fellowship for Interpretation of
# Genomes at veronika@thefig.info or download a copy from
# http://www.theseed.org/LICENSE.TXT.
#

### subsys_hope.cgi ###
#
# Copy of subsys.cgi from early August 2005 with option added to view
# functional roles with EC's in the context of relevant KEGG maps.
#
# Author: Kevin Formsma
# Contact: kevin.formsma@hope.edu
# Hope College, Summer Research 2005 REU
###################

use FIG;
use FIGjs;  # mouseover()
use KGMLData; # to parse relations in KEGG maps
my $fig = new FIG;

use Subsystem;

use URI::Escape;  # uri_escape()
use HTML;
use strict;
use tree_utilities;

use CGI;

my $cgi = new CGI;
if (0)
{
    my $VAR1;
    eval(join("",`cat /tmp/ssa_parms`));
    $cgi = $VAR1;
#   print STDERR &Dumper($cgi);
}

if (0)
{
    print $cgi->header;
    my @params = $cgi->param;
    print "<pre>\n";
    foreach $_ (@params)
    {
	print "$_\t:",join(",",$cgi->param($_)),":\n";
    }

    if (0)
    {
	if (open(TMP,">/tmp/ssa_parms"))
	{
	    print TMP &Dumper($cgi);
	    close(TMP);
	}
    }
    exit;
}

# request to display the phylogenetic tree
#
my $request = $cgi->param("request");
if ($request && ($request eq "show_tree"))
{
    print $cgi->header;
    &show_tree;
    exit;
}

my $html = [];
push @$html, "<TITLE>SEED Subsystems</TITLE>\n"; # RAE: every page deserves a title

my $user = $cgi->param('user');
$fig->set_user($user);

if ($cgi->param('resynch_peg_connections') && (my $ssa = $cgi->param('ssa_name')))
{
    my $subsystem = new Subsystem($ssa,$fig,0);
    $subsystem->db_sync(0);
    undef $subsystem;
    &one_cycle($fig,$cgi,$html);
}
elsif ($user && ($cgi->param("extend_with_billogix")))
{
    #
    # Start a bg task to extend the subsystem.
    #

    my $ssa = $cgi->param('ssa_name');

    my $user = $cgi->param('user');

    my $sub = $fig->get_subsystem($ssa);

    if ($sub && ($user eq $sub->get_curator))
    {
	#
	# See if there's already an extend job running.
	#
	    
	my $curpid = $sub->get_current_extend_pid();
	if ($curpid)
	{
	    warn "Found current pid $curpid\n";
	    my $j = $fig->get_job($curpid);
	    warn "job is $j\n";
	    warn "running is ", $j->running(), "\n" if $j;
	    if ($j && $j->running())
	    {
		push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
		     "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status");
		last;
	    }
	}
	
	my $pid = $fig->run_in_background(sub {$sub->extend_with_billogix($user);});
	    
	push(@$html,
	     "Subsystem extension started as background job number $pid <br>\n",
	     "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status");
	    
	$sub->set_current_extend_pid($pid);
    }
    else
    {
	push(@$html, "Subsystem '$ssa' could not be loaded");
    }
    &HTML::show_page($cgi, $html);
    exit;
}
else
{
    $request = defined($request) ? $request : "";
    
    if    (($request eq "reset") && $user)
    {
	&reset_ssa($fig,$cgi,$html);        # allow user to go back to a previous version of the ss
    }
    elsif    (($request eq "reset_to") && $user)
    {
	&reset_ssa_to($fig,$cgi,$html);     # this actually resets to the previous version
	&one_cycle($fig,$cgi,$html);
    }
    elsif    (($request eq "make_exchangable") && $user)
    {
	&make_exchangable($fig,$cgi,$html);
	&show_initial($fig,$cgi,$html);
    }
    elsif    (($request eq "make_unexchangable") && $user)
    {
	&make_unexchangable($fig,$cgi,$html);
	&show_initial($fig,$cgi,$html);
    }
    elsif    ($request eq "show_ssa")
    {
	if ($_ = $cgi->param('check'))
	{
	    push(@$html,$cgi->h1('CHECKING SUBSYSTEM'),
		        &check_ssa($fig,$cgi),
		        $cgi->hr
		 );
	}
	&one_cycle($fig,$cgi,$html);
    }
    #
    # Note that this is a little different; I added another submit button
    # to the delete_or_export_ssa form, so have to distinguish between them
    # here based on $cgi->param('delete_export') - the original button,
    # or $cgi->param('publish') - the new one.
    #
    elsif (($request eq "delete_or_export_ssa") && $user &&
	    defined($cgi->param('delete_export')))
    {
	my($ssa,$exported);
	$exported = 0;
	foreach $ssa ($cgi->param('export'))
	{
	    if (! $exported)
	    {
		print $cgi->header;
		print "<pre>\n";
	    }
	    &export($fig,$cgi,$ssa);
	    $exported = 1;
	}

	foreach $ssa ($cgi->param('export_assignments'))
	{
	    &export_assignments($fig,$cgi,$ssa);
	}

	foreach $ssa ($cgi->param('delete'))
	{
	    my $sub = $fig->get_subsystem($ssa);
	    $sub->delete_indices();
	    
	    my $cmd = "rm -rf '$FIG_Config::data/Subsystems/$ssa'";
	    my $rc = system $cmd;
	}

	if (! $exported)
	{
		    &show_initial($fig,$cgi,$html);
		}
		else
		{
		    print "</pre>\n";
		    exit;
		}
	    }
	    elsif (($request eq "delete_or_export_ssa") && $user &&
		   defined($cgi->param('publish')))
	    {
		my($ssa,$exported);
		my($ch) = $fig->get_clearinghouse();

		print $cgi->header;

		if (!defined($ch))
		{
		    print "cannot publish: clearinghouse not available\n";
		    exit;
		}
		
		foreach $ssa ($cgi->param('publish_to_clearinghouse'))
		{
		    print "<h2>Publishing $ssa to clearinghouse...</h2>\n";
		    $| = 1;
		    print "<pre>\n";
		    my $res = $fig->publish_subsystem_to_clearinghouse($ssa);
		    print "</pre>\n";
		    if ($res)
		    {
			print "Published <i>$ssa </i> to clearinghouse<br>\n";
		    }
		    else
		    {
			print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\n";
		    }
		}
		exit;
	    }
	    elsif (($request eq "delete_or_export_ssa") && $user &&
		       defined($cgi->param('reindex')))
	    {
	     
		 my @ss=$cgi->param('index_subsystem');
		 my $job = $fig->index_subsystems(@ss);
		 push @$html, "<h2>ReIndexing these subsystems...</h2>\n<ul>", map {"<li>$_</li>"} @ss;
		 push @$html, "</ul>\n<p>... is running in the background with job id $job. You may check it in the ",
		   "<a href=\"seed_ctl.cgi?user=$user\">SEED Control Panel</a></p>\n";
	 &show_initial($fig,$cgi,$html);
    }
    elsif ($user && ($request eq "new_ssa") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1')))
    {
	my $user = $cgi->param('user');
	my $name = $cgi->param('ssa_name');
	my $copy_from1 = $cgi->param('copy_from1');
	my $copy_from2 = $cgi->param('copy_from2');
        my(@roles1,@roles2);

	push(@$html,$cgi->start_form(-action => "subsys_hope.cgi",
				     -method => 'post'),
	            $cgi->hidden(-name => 'copy_from1', -value => $copy_from1, -override => 1),
	            $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	            $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
	            $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1)
	     );

	@roles1 = $fig->subsystem_to_roles($copy_from1);
	if (@roles1 > 0)
	{
	    push(@$html,$cgi->h1("select columns to be taken from $copy_from1"),
		        $cgi->scrolling_list(-name => 'cols_to_take1',
					     -values => ['all',@roles1],
					     -size => 10,
					     -multiple => 1
					     ),
		        $cgi->hr
	     );
	}

	if ($copy_from2)
	{
	    @roles2 = $fig->subsystem_to_roles($copy_from2);
	    if (@roles2 > 0)
	    {
		push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1));
		push(@$html,$cgi->h1("select columns to be taken from $copy_from2"),
		            $cgi->scrolling_list(-name => 'cols_to_take2',
						 -values => ['all',@roles2],
						 -size => 10,
						 -multiple => 1
						 ),
		            $cgi->hr
		     );
	    }
	}
	push(@$html,$cgi->submit('build new subsystem'),
	            $cgi->end_form
	     );
    }
    elsif ($user && ($request eq "new_ssa") && ($cgi->param('move_from')))
    {
	my $user = $cgi->param('user');
	my $name = $cgi->param('ssa_name');
	$name=$fig->clean_spaces($name);
	$name=~s/ /_/g;
	my $move_from = $cgi->param('move_from');
        if (-d "$FIG_Config::data/Subsystems/$move_from" && !(-e "$FIG_Config::data/Subsystems/$name")) {
	 my $res=`mv $FIG_Config::data/Subsystems/$move_from $FIG_Config::data/Subsystems/$name`;
	 my $job = $fig->index_subsystems($name);
	 push @$html, "<p>The subsystem <b>$move_from</b> was moved to <b>$name</b> and got the result $res. The new subsystem is being indexed with job id $job\n",
	  "(check the <a href=\"seed_ctl.cgi?user=$user\">SEED control panel</a> for more information</p>\n";
	} 
	elsif (-e "$FIG_Config::data/Subsystems/$name") 
	{
	 push @$html, "<p>The subsystem <b>$move_from</b> was <b><i>NOT</i></b> moved because the subsystem $name already exists</p>";
	}
	else {
	 push @$html, "<p>The subsystem <b>$move_from</b> was not found. Sorry</p>";
	}
        &show_initial($fig,$cgi,$html);
    }	 	
    elsif ($request eq "new_ssa")
    {
	&new_ssa($fig,$cgi,$html);
    }
    else
    {
	&show_initial($fig,$cgi,$html);
    }
}

&HTML::show_page($cgi,$html);
exit;


sub show_initial {
    my($fig,$cgi,$html) = @_;
    my($set,$when,$comment);

    my $user = $cgi->param('user');
    my @ssa = &existing_subsystem_annotations($fig);

    if (@ssa > 0)
    {
	&format_ssa_table($cgi,$html,$user,\@ssa);
    }

    my $target = "window$$";
    push(@$html, $cgi->h1('To Start or Copy a Subsystem'),
                 $cgi->start_form(-action => "subsys_hope.cgi",
				  -target => $target,
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
	         "Name of New Subsystem: ",
	         $cgi->textfield(-name => "ssa_name", -size => 50),
	         $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
	         $cgi->br,

	         "Copy from (leave blank to start from scratch): ",
	         $cgi->textfield(-name => "copy_from1", -size => 50),
	         $cgi->br,

	         "Copy from (leave blank to start from scratch): ",
	         $cgi->textfield(-name => "copy_from2", -size => 50),
	         $cgi->br,

		 "Move from (leave blank to start from scratch): ",
		 $cgi->textfield(-name => "move_from", -size => 50),
		 $cgi->br,

	         $cgi->submit('start new subsystem'),
	         $cgi->end_form,
	         "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\"
fields blank.  If you wish to just copy a subsystem (in order to become the owner so that you can modify it),
just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy.  If you wish to
extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one),
fill in the name of the subsystem.  You will be prompted for the columns that you wish to extract (choose <i>all</i> to
just copy all of the columns).  Finally, if you wish to build a new spreadsheet by including columns from two existing
spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems"
	 );
}		  

sub new_ssa {
    my($fig,$cgi,$html) = @_;

    my $user = $cgi->param('user');
    my $name = $fig->clean_spaces($cgi->param('ssa_name')); # RAE remove extraneous spaces in the name

    if  (! $user)
    {
	push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation'));
	return;
    }

    if  (! $name)
    {
	push(@$html,$cgi->h1("You need to specify a subsystem name, $name is not valid"));
	return;
    }

    my $ssa  = $name;
    $ssa =~ s/[ \/]/_/g;

    &FIG::verify_dir("$FIG_Config::data/Subsystems");

    if (-d "$FIG_Config::data/Subsystems/$ssa")
    {
	push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used"));
	return;
    }

    my $subsystem = new Subsystem($ssa,$fig,1);    # create new subsystem

    my $copy_from1 = $cgi->param('copy_from1');
    $copy_from1 =~ s/[ \/]/_/g;
    my $copy_from2 = $cgi->param('copy_from2');
    $copy_from2 =~ s/[ \/]/_/g;
    my @cols_to_take1 = $cgi->param('cols_to_take1');
    my @cols_to_take2 = $cgi->param('cols_to_take2');

    
    if ($copy_from1 && (@cols_to_take1 > 0))
    {
	$subsystem->add_to_subsystem($copy_from1,\@cols_to_take1,"take notes");  # add columns and notes
    }

    if ($copy_from2 && (@cols_to_take2 > 0))
    {
	$subsystem->add_to_subsystem($copy_from2,\@cols_to_take2,"take notes");  # add columns and notes
    }

    $subsystem->write_subsystem();

    $cgi->param(-name  => "ssa_name",
    		-value => $ssa); # RAE this line was needed because otherwise a newly created subsystem was not opened!
    $cgi->param(-name  => "can_alter",
		-value => 1);
    &one_cycle($fig,$cgi,$html);
}

# The basic update logic (cycle) includes the following steps:
# 
#     1. Load the existing spreadsheet
#     2. reconcile row and subset changes
#     3. process spreadsheet changes (fill/refill/add genomes/update variants)
#     4. write the updated spreadsheet back to disk
#     5. render the spreadsheet
#
sub one_cycle {
    my($fig,$cgi,$html) = @_;
    my $subsystem;

    my $user = $cgi->param('user');
    my $ssa  = $cgi->param('ssa_name');

    if  ((! $ssa) || (! ($subsystem = new Subsystem($ssa,$fig,0))))
    {
	push(@$html,$cgi->h1('You need to specify a subsystem'));
	return;
    }
    
    if ($cgi->param('can_alter') && ($user = $cgi->param('user')) && ($user eq $subsystem->get_curator))
    {
	handle_diagram_changes($fig, $subsystem, $cgi, $html);
    }

    if (&handle_role_and_subset_changes($fig,$subsystem,$cgi,$html))
    {
	&process_spreadsheet_changes($fig,$subsystem,$cgi,$html);

	if ($cgi->param('can_alter') && ($user = $cgi->param('user')) && ($user eq $subsystem->get_curator))
	{
	    $subsystem->write_subsystem();
	}

	my $col;
	if ($cgi->param('show_sequences_in_column') && 
	    ($col = $cgi->param('col_to_align')) && 
	    ($col =~ /^\s*(\d+)\s*$/))
	{
	    &show_sequences_in_column($fig,$cgi,$html,$subsystem,$col);
	}
	else
	{
	    if ($cgi->param('align_column') && 
		($col = $cgi->param('col_to_align')) && ($col =~ /^\s*(\d+)\s*$/))
	    {
		my $col = $1;
		&align_column($fig,$cgi,$html,$col,$subsystem);
		$cgi->delete('col_to_align');
	    }
	    elsif ($cgi->param('realign_column') &&
		   ($col = $cgi->param('subcol_to_realign')) && ($col =~ /^\s*(\d+)\.(\d+)\s*$/))
	    {
		&align_subcolumn($fig,$cgi,$html,$1,$2,$subsystem);
		$cgi->delete('subcol_to_realign');
	    }
	    &produce_html_to_display_subsystem($fig,$subsystem,$cgi,$html,$ssa);
	}
    }
}

sub handle_role_and_subset_changes {
    my($fig,$subsystem,$cgi,$html) = @_;
    my $user;

    if ((! $cgi->param('can_alter')) || (! ($user = $cgi->param('user'))) || ($user ne $subsystem->get_curator))
    {
	return 1;    # no changes, so...
    }
    else
    {
	my @roles = $subsystem->get_roles;
	my($rparm,$vparm);
	foreach $rparm (grep { $_ =~ /^react\d+/ } $cgi->param)
	{
	    if ($vparm = $cgi->param($rparm))
	    {
		$vparm =~ s/ //g;
		$rparm =~ /^react(\d+)/;
		my $roleN  = $1 - 1;
		$subsystem->set_reaction($roles[$roleN],$vparm);
	    }
	}

	my($role,$p,$abr,$r,$n);
	my @tuplesR = ();

###     NOTE: the meaning (order) or @roles shifts here to the NEW order
	@roles   = grep { $_ =~ /^role/ }   $cgi->param();
	if (@roles == 0)  { return 1 }     # initial call, everything is as it was

	foreach $role (@roles)
	{
	    if (($role =~ /^role(\d+)/) && defined($n = $1))
	    {
		if ($r = $cgi->param("role$n"))
		{
		    $r =~ s/^\s+//;
		    $r =~ s/\s+$//;

		    if (($p = $cgi->param("posR$n")) && ($abr = $cgi->param("abbrev$n")))
		    {
			push(@tuplesR,[$p,$r,$abr]);
		    }
		    else
		    {
			push(@$html,$cgi->h1("You need to give a position and abbreviation for $r"));
			return 0;
		    }
		}
	    }
	}
	@tuplesR = sort { $a->[0] <=> $b->[0] } @tuplesR;
	$subsystem->set_roles([map { [$_->[1],$_->[2]] } @tuplesR]);

	my($subset_name,$s,$test,$entries,$entry);
	my @subset_names  = grep { $_ =~ /^nameCS/ } $cgi->param();

	if (@subset_names == 0) { return 1 }

	my %defined_subsetsC;
	foreach $s (@subset_names)
	{
	    if (($s =~ /^nameCS(\d+)/) && defined($n = $1) && ($subset_name = $cgi->param($s)))
	    {

		my($text);
		$entries = [];
		if ($text = $cgi->param("subsetC$n"))
		{
		    foreach $entry (split(/[\s,]+/,$text))
		    {
			if ($role = &to_role($entry,\@tuplesR))
			{
			    push(@$entries,$role);
			}
			else
			{
			    push(@$html,$cgi->h1("Invalid role designation in subset $s: $entry"));
			    return 0;
			}
		    }
		}
		$defined_subsetsC{$subset_name} = $entries;
	    }
	}

	foreach $s ($subsystem->get_subset_namesC)
	{
	    next if ($s eq "All");
	    if ($entries = $defined_subsetsC{$s})
	    {
		$subsystem->set_subsetC($s,$entries);
		delete $defined_subsetsC{$s};
	    }
	    else
	    {
		$subsystem->delete_subsetC($s);
	    }
	}

	foreach $s (keys(%defined_subsetsC))
	{
	    $subsystem->set_subsetC($s,$defined_subsetsC{$s});
	}

	my $active_subsetC;
	if ($active_subsetC = $cgi->param('active_subsetC'))
	{
	    $subsystem->set_active_subsetC($active_subsetC);
	}
    }
    return 1;
}

sub to_role {
    my($x,$role_tuples) = @_;
    my $i;

    if (($x =~ /^(\d+)$/) && ($1 <= @$role_tuples)) { return $role_tuples->[$x-1]->[1] }

    for ($i=0; ($i < @$role_tuples) && 
	       ($role_tuples->[0] != $x) &&
	       ($role_tuples->[1] != $x) &&
	 ($role_tuples->[2] != $x); $i++) {}
    if ($i < @$role_tuples)
    {
	return $role_tuples->[$i]->[1];
    }
    return undef;
}
    
sub process_spreadsheet_changes {
    my($fig,$subsystem,$cgi,$html) = @_;

    my $user;
    if ((! $cgi->param('can_alter')) || (! ($user = $cgi->param('user'))) || ($user ne $subsystem->get_curator))
    {
	return 1;    # no changes, so...
    }
    else
    {
	my $notes = $cgi->param('notes');
	if ($notes)
	{
	    $subsystem->set_notes($notes);
	}
	if ($cgi->param('classif1') || $cgi->param('classif2'))
	{
	 my $class;
	 @$class=($cgi->param('classif1'), $cgi->param('classif2'));
	 $subsystem->set_classification($class);
	}

	my(@param,$param,$genome,$val);
	@param = grep { $_ =~ /^genome\d+\.\d+$/ } $cgi->param;

	my %removed;
	foreach $param (@param)
	{
	    if ($cgi->param($param) =~ /^\s*$/)
	    {
		$param =~ /^genome(\d+\.\d+)/;
		$genome = $1;
		$subsystem->remove_genome($genome);
		$removed{$genome} = 1;
	    }
	}

	@param = grep { $_ =~ /^vcode\d+\.\d+$/ } $cgi->param;
	foreach $param (@param)
	{
	    if ($cgi->param($param) =~ /^\s*(\S+)\s*$/)
	    {
		$val = $1;
		$param =~ /^vcode(\d+\.\d+)/;
		$genome = $1;
		if (! $removed{$genome})
		{
		    $subsystem->set_variant_code($subsystem->get_genome_index($genome),$val);
		}
	    }
	}
	
	if ($cgi->param('refill'))
	{
	    &refill_spreadsheet($fig,$subsystem);
	}
	elsif ($cgi->param('precise_fill'))
	{
	    &fill_empty_cells($fig,$subsystem);
	}

	my @orgs = $cgi->param('new_genome');
	@orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;

	my $org;
	foreach $org (@orgs)
	{
	    &add_genome($fig,$subsystem,$cgi,$html,$org);
	}

	my $active_subsetR;
	if ($active_subsetR = $cgi->param('active_subsetR'))
	{
	    $subsystem->set_active_subsetR($active_subsetR);
	}
    }
}

sub refill_spreadsheet {
    my($fig,$subsystem) = @_;
    my($genome,$role,@pegs1,@pegs2,$i);

    foreach $genome ($subsystem->get_genomes())
    {
	foreach $role ($subsystem->get_roles())
	{
	    @pegs1 = sort $subsystem->get_pegs_from_cell($genome,$role);
	    @pegs2 = sort $fig->seqs_with_role($role,"master",$genome);

	    if (@pegs1 != @pegs2)
	    {
		$subsystem->set_pegs_in_cell($genome,$role,\@pegs2);
	    }
	    else
	    {
		for ($i=0; ($i < @pegs1) && ($pegs1[$i] eq $pegs2[$i]); $i++) {}
		if ($i < @pegs1)
		{
		    $subsystem->set_pegs_in_cell($genome,$role,\@pegs2);
		}
	    }
	}
    }
}

sub fill_empty_cells {
    my($fig,$subsystem) = @_;
    my($genome,$role,@pegs);

    foreach $genome ($subsystem->get_genomes())
    {
	foreach $role ($subsystem->get_roles())
	{
	    @pegs = $subsystem->get_pegs_from_cell($genome,$role);
	    if (@pegs == 0)
	    {
		@pegs = $fig->seqs_with_role($role,"master",$genome);
		if (@pegs > 0)
		{
		    $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
		}
	    }
	}
    }
}

sub add_genome {
    my($fig,$subsystem,$cgi,$html,$genome) = @_;
    my($role,@pegs);
    
    $subsystem->add_genome($genome);
    foreach $role ($subsystem->get_roles())
    {
	@pegs = $fig->seqs_with_role($role,"master",$genome);
	$subsystem->set_pegs_in_cell($genome,$role,\@pegs);
    }
}

sub produce_html_to_display_subsystem {
    my($fig,$subsystem,$cgi,$html,$ssa) = @_;

    my $user = $cgi->param('user');
    my $ssa  = $cgi->param('ssa_name');
    my $can_alter = ($cgi->param('can_alter') && $user && ($user eq $subsystem->get_curator));
    my $tagvalcolor; # RAE: this is a reference to a hash that stores the colors of cells by tag. This has to be consistent over the whole table.

    my $name  = $ssa;
    $name =~ s/_/ /g;
    $ssa =~ s/[ \/]/_/g;
    my $curator = $fig->subsystem_curator($ssa);
    push(@$html, $cgi->h1("Subsystem: $name"),
	         $cgi->h1("Author: $curator"),
                 $cgi->start_form(-action => "subsys_hope.cgi",
				  -method => 'post',
				  -enctype => &CGI::MULTIPART),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'show_ssa', -override => 1),
	         $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
	         $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
	         $cgi->br,
	 );

    # RAE: First, a sanity check.
    # We may have to move this a little earlier, and show probably throw some nicer
    # errors to the end user (.e.g try setting can_alter and choosing an illegitimate ss
    # Do we know about this subsystem:
    my $ssaQ = quotemeta $ssa;
    unless (grep {/$ssaQ/} map {$_->[0]} &existing_subsystem_annotations($fig))
    {
     # No, we don't know about this subsystem
     my $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user";
     push @$html, "Sorry. $name is not a valid subsystem. <p>\n",
     "Please return to the <a href=\"$url\">Subsystems Page</a> and choose an exisiting subsystem. <p>\n",
     "Sorry.";
     return undef;
    }
    

    &format_roles($fig,$cgi,$html,$subsystem,$can_alter);
    &format_subsets($fig,$cgi,$html,$subsystem,$can_alter);

    &format_diagrams($fig, $cgi, $html, $subsystem, $can_alter);

    #
    # Put link into constructs tool.
    #

    if ($can_alter)
    {
	push(@$html, $cgi->p,
	     $cgi->a({href => "construct.cgi?ssa=$ssa&user=$user",
			  target => "_blank"},
		     "Define higher level constructs."),
	     $cgi->p);
    }


    #  Display the subsystem table rows, saving the list genomes displayed

    my $active_genome_list = &format_rows($fig,$cgi,$html,$subsystem, $tagvalcolor);


    if ( $can_alter ) { format_extend_with($fig,$cgi,$html,$subsystem) }

    my $esc_ssa = uri_escape( $ssa );
    push @$html, "<TABLE width=\"100%\">\n",
                 "    <TR>\n",
                 ($can_alter) ? "        <TD>" . $cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill') . "</TD>\n" : (),
	             "        <TD><a href=\"/FIG/Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a></TD>\n",
	             "        <TD><a href=\"/FIG/Html/seedtips.html#edit_variants\" class=\"help\" target=\"help\">Help on editing variants</a></TD>\n",
	             "        <TD><a href=\"ss_export.cgi?user=$user&ssa_name=$esc_ssa\" class=\"help\">Export subsystem data</a></TD>\n",
                 "    </TR>\n",
                 "</TABLE>\n";
    
    if ($can_alter)
    {
        push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
    }
    else
    {
	push(@$html,$cgi->br);
	push(@$html,$cgi->submit('show spreadsheet'),$cgi->br);
    }
    push(@$html,$cgi->checkbox(-name => 'show_KGML', -value =>1, -checked=>0, -label => 'show KEGG data'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'ignore_alt', -value => 1, -override => 1, -label => 'ignore alternatives', -checked => ($cgi->param('ignore_alt'))),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'ext_ids', -value => 1, -checked => 0, -label => 'use external ids'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0,-label => 'show clusters'),$cgi->br);
    my $opt=$fig->get_tags("genome"); # all the tags we know about
    my @options=sort {uc($a) cmp uc($b)} keys %$opt;
    unshift(@options, undef); # a blank field at the start
    push(@$html,"color rows by each organism's attribute: &nbsp; ", $cgi->popup_menu(-name => 'color_by_ga', -values=>\@options), $cgi->br);

    $opt=$fig->get_tags("peg"); # all the peg tags
    @options=sort {$a cmp $b} keys %$opt;
    unshift(@options, undef); 
    push(@$html,"color columns by each PEGs attribute: &nbsp; ", $cgi->popup_menu(-name => 'color_by_peg_tag', -values=>\@options), $cgi->br);
    
    push @$html, $cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'),
                 $cgi->br, $cgi->br;


    #  Format the organism list for a pop-up menu:

    my @genomes = sort { lc $a->[1] cmp lc $b->[1] } map { [ $_->[0], "$_->[1] [$_->[0]]" ] } @$active_genome_list;
    unshift @genomes, [ '', 'select it in this menu' ];

    # Make a list of index number and roles for pop-up selections:

    my @roles = map { [ $subsystem->get_role_index( $_ ) + 1, $_ ] } $subsystem->get_roles;
    unshift @roles, [ '', 'select it in this menu' ];

    push @$html,  "<table><tr><td>",
                  $cgi->checkbox(-name => 'show_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'), $cgi->br,
	          $cgi->checkbox(-name => 'show_missing_including_matches_in_ss', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches in ss'), "&nbsp;&nbsp;",
                  "</td>\n<td><big><big><big>} {</big></big></big></td>",
                  "<td>",
	          "[To restrict to a single genome: ",
                  $cgi->popup_menu( -name   => 'just_genome',
                                    -values => [ map {   $_->[0]            } @genomes ],
                                    -labels => { map { ( $_->[0], $_->[1] ) } @genomes }
                                  ), "]", $cgi->br,
	          "[To restrict to a single role: ",
                  $cgi->popup_menu( -name   => 'just_role',
                                    -values => [ map {   $_->[0]            } @roles ],
                                    -labels => { map { ( $_->[0], $_->[1] ) } @roles }
                                  ),
	          "]</td></tr></table>\n",
	          $cgi->br;


    push @$html,  "<table><tr><td>",
                  $cgi->checkbox(-name => 'check_assignments', -value => 1, -checked => 0, -override => 1, -label => 'check assignments'),
                  "&nbsp;&nbsp;[", $cgi->checkbox(-name => 'strict_check', -value => 1, -checked => 0, -override => 1, -label => 'strict'), "]&nbsp;&nbsp;",
                  "</td>\n<td><big><big><big>{</big></big></big></td>",
                  "<td>",
	          "[To restrict to a single genome: ",
                  $cgi->popup_menu( -name   => 'just_genome_assignments',
                                    -values => [ map {   $_->[0]            } @genomes ],
                                    -labels => { map { ( $_->[0], $_->[1] ) } @genomes }
                                  ), "]", $cgi->br,
	          "[To restrict to a single role: ",
                  $cgi->popup_menu( -name   => 'just_role_assignments',
                                    -values => [ map {   $_->[0]            } @roles ],
                                    -labels => { map { ( $_->[0], $_->[1] ) } @roles }
                                  ),
	          "]</td></tr></table>\n",
	          $cgi->br;


    if ($can_alter)
    {
	push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$cgi->br);
    }

    push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'check_problems', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs in roles that do not match precisely'),$cgi->br);
    if ($can_alter)
    {
	push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'add genomes with solid hits'),$cgi->br);
    }

    push(@$html,$cgi->checkbox(-name => 'show_coupled_fast', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs fast [depends on existing pins/clusters]'),$cgi->br);

    push(@$html,$cgi->checkbox(-name => 'show_coupled', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs [figure 2 minutes per PEG in spreadsheet]'),$cgi->br);

    # RAE Hide -1 variants
    push(@$html,$cgi->checkbox(-name => 'show_minus1', -value=> 1, -checked => 0, -label => 'show -1 variants'),$cgi->br);

    #  Alignment functions:

    push @$html, $cgi->hr,
	         # $cgi->br, "Column (specify the number of the column): ",
	         # $cgi->textfield(-name => "col_to_align", -size => 7),
	         "For sequences in a column (i.e., role): ",
                 $cgi->popup_menu( -name   => 'col_to_align',
                                   -values => [ map {   $_->[0]            } @roles ],
                                   -labels => { map { ( $_->[0], $_->[1] ) } @roles }
                                 ),
	         $cgi->br,
	         $cgi->submit(-value => "Show Sequences in Column",
	                      -name  => "show_sequences_in_column"),
	         $cgi->br,
	         $cgi->submit(-value => "Align Sequences in Column",
	                      -name  => "align_column"),
	         $cgi->br,
	         $cgi->br, "Realign subgroup within a column (adding homologs): ",
	         $cgi->textfield(-name => "subcol_to_realign", -size => 7),
	         $cgi->br, "Include homologs that pass the following threshhold: ",
	         $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)",
	         " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6),
	         $cgi->br,
	         $cgi->submit(-value => "Realign Sequences in Column",
	                      -name  => "realign_column"),
	         $cgi->hr;

     # RAE: A new function to reannotate a single column
     # I don't understand how you get CGI.pm to reset (and never have).
     # $cgi->delete("col_to_annotate"); # this does nothing to my script and there is always the last number in this box
     #push(@$html, $cgi->br,"Change annotation for column: ", $cgi->textfield(-name => "col_to_annotate", -size => 7));
     push(@$html, $cgi->br,"Change annotation for column: ", '<input type="text" name="col_to_annotate" value="" size="7">');

    if ($can_alter)
    {
	push(@$html,
	     $cgi->p. $cgi->hr."If you wish to check the subsystem, ",
	     $cgi->a({href => "check_subsys.cgi?user=$user&subsystem=$ssa&request=check_ssa"},
		     "click here"),
#	     $cgi->br,
#	     $cgi->p. $cgi->hr."If you wish to reset variants for the subsystem, ",
#	     $cgi->a({href => "set_variants.cgi?user=$user&subsystem=$ssa&request=show_variants",target => "set_variants"},
#		     "click here"),
	     $cgi->br,
	     $cgi->p,
	     $cgi->hr,
	     "You should resynch PEG connections only if you detect PEGs that should be connected to the
              spreadsheet, but do not seem to be.  This can only reflect an error in the code.  If you find
              yourself having to use it, send mail to Ross.",
	     $cgi->br,
	     $cgi->submit(-value => "Resynch PEG Connections",
			  -name => "resynch_peg_connections"),
	     $cgi->br,
	     $cgi->submit(-value => "Start automated subsystem extension",
			     -name => "extend_with_billogix"),
	     $cgi->br);
    }

    my $notes = $subsystem->get_notes();
    if ($can_alter)
    {
	push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 40, -cols => 100, -value => $notes));
    }
    elsif ($notes)
    {
	push(@$html,$cgi->h2('notes'),"<pre width=80>$notes</pre>");
    }

    # RAE Modified to add a line with the classification
    my $class=$subsystem->get_classification();
    if ($can_alter)
    {
       push(@$html, $cgi->hr, "CLASSIFICATION:\n", $cgi->textfield(-name=>"classif1", -value=>$$class[0], -size=>40), 
       	$cgi->textfield(-name=>"classif2", -value=>$$class[1], -size=>40));
    }
    elsif ($class)
    {
       push (@$html, $cgi->h2('Classification'), "<table><tr><td>$$class[0]</td><td>$$class[1]</td></tr></table>\n");
    }

    push(@$html, $cgi->end_form);

    my $target = "align$$";
    my @roles = $subsystem->get_roles;
    my $i;
    my $dir = $subsystem->get_dir;
    my $rolesA = &existing_trees($dir,\@roles);
    
    if (@$rolesA > 0)
    {
	push(@$html, $cgi->hr,
	             $cgi->h1('To Assign Using a Tree'),
	             $cgi->start_form(-action => "assign_using_tree.cgi",
				      -target => $target,
				      -method => 'post'),
	             $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	             $cgi->hidden(-name => 'ali_dir', -value => "$dir/Alignments", -override => 1),
	             $cgi->scrolling_list(-name => 'ali_num',
					  -values => $rolesA,
					  -size => 10,
					  -multiple => 0
					  ),
	             $cgi->br,
	             $cgi->submit(-value => "use_tree",
				  -name => "use_tree"),
	             $cgi->end_form
	 );
    }

    push(@$html, $cgi->hr);
    
	 #start editing
	if ($cgi->param('show_KGML'))
	{	
		my $kgml = new KGMLData;
		$kgml->show_matching_pathways($subsystem,$cgi,$html);
	}
	#end editing
    if ($cgi->param('show_missing'))
    {
	&format_missing($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_missing_including_matches'))
    {
	&format_missing_including_matches($fig,$cgi,$html,$subsystem);
    }
    if ($cgi->param('show_missing_including_matches_in_ss'))
    {
	&format_missing_including_matches_in_ss($fig,$cgi,$html,$subsystem);
    }
     

    if ($cgi->param('check_assignments'))
    {
	&format_check_assignments($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_dups'))
    {
	&format_dups($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_coupled'))
    {
	&format_coupled($fig,$cgi,$html,$subsystem,"careful");
    }
    elsif ($cgi->param('show_coupled_fast'))
    {
	&format_coupled($fig,$cgi,$html,$subsystem,"fast");
    }

    my $col;
    if ($col = $cgi->param('col_to_annotate'))
    {
        &annotate_column($fig,$cgi,$html,$col,$subsystem);
    }
}


#-----------------------------------------------------------------------------
#  Selection list of complete genomes not in spreadsheet:
#-----------------------------------------------------------------------------

sub format_extend_with {
    my( $fig, $cgi, $html, $subsystem ) = @_;

    my %genomes = map { $_ => 1 } $subsystem->get_genomes();

    #
    #  Use $fig->genomes( complete, restricted, domain ) to get org list:
    #
    my $req_comp = $cgi->param( 'complete' ) || 'Only "complete"';
    my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete";
    my @orgs = map { [ $_ , &ext_genus_species( $fig, $_ ) ] }
               grep { ! $genomes{ $_ } }
               $fig->genomes( $complete, undef );

    #
    #  Put it in the order requested by the user:
    #
    my $pick_order = $cgi->param('pick_order') || 'Alphabetic';
    if ( $pick_order eq "Phylogenetic" )
    {
	@orgs = sort { $a->[2] cmp $b->[2] }
	        map  { push @$_, $fig->taxonomy_of( $_->[0] ); $_ }
	        @orgs;
    }
    elsif ( $pick_order eq "Genome ID" )
    {
	@orgs = sort { $a->[2]->[0] <=> $b->[2]->[0] || $a->[2]->[1] <=> $b->[2]->[1] }
	        map  { push @$_, [ split /\./ ]; $_ }
	        @orgs;
    }
    else
    {
	$pick_order = 'Alphabetic';
	@orgs = sort { $a->[1] cmp $b->[1] } @orgs;
    }

    @orgs = map { "$_->[1] ($_->[0])" } @orgs;

    #
    #  Radio buttons to let the user choose the order they want for the list:
    #
    my @order_opt = $cgi->radio_group( -name     => 'pick_order',
                                       -values   => [ 'Alphabetic', 'Phylogenetic', 'Genome ID' ],
                                       -default  => $pick_order,
                                       -override => 1
                                     );

    #
    #  Radio buttons to let the user choose to include incomplete genomes:
    #
    my @complete = $cgi->radio_group( -name     => 'complete',
                                      -default  => $req_comp,
                                      -override => 1,
                                      -values   => [ 'All', 'Only "complete"' ]
                        );

    #
    #  Display the pick list, and options:
    #
    push( @$html, $cgi->h1('Pick Organisms to Extend with'), "\n",
                  "<TABLE>\n",
                  "  <TR>\n",
                  "    <TD>",
                  $cgi->scrolling_list( -name     => 'new_genome',
                                        -values   => [ @orgs ],
                                        -size     => 10,
                                        -multiple => 1
                                      ),
                  "    </TD>\n",
                  "    <TD>",
                  join( "<BR>\n", "<b>Order of selection list:</b>", @order_opt,
                                  "<b>Completeness?</b>", @complete
                      ), "\n",
                  "    </TD>\n",
                  "  </TR>\n",
                  "</TABLE>\n",
                  $cgi->hr
         );
}


sub format_roles {
    my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
    my($i);

    my @roles = $subsystem->get_roles;
    my $sub_dir = $subsystem->get_dir;

    my $reactions = $subsystem->get_reactions;

    my $n = 1;
    my $col_hdrs = ["Column","Abbrev","Functional Role"];

    if ($can_alter)
    { 
	push(@$col_hdrs,"KEGG Reactions");
	push(@$col_hdrs,"Edit Reactions");
    }
    elsif ($reactions)
    {
	push(@$col_hdrs,"KEGG Reactions");
    }

    my $tab = [];

    &format_existing_roles($fig,$cgi,$html,$subsystem,$tab,\$n,$can_alter,$reactions,\@roles);
    if ($cgi->param('can_alter'))
    {
	for ($i=0; ($i < 5); $i++)
	{
	    &format_role($fig,$cgi,$html,$subsystem,$tab,$n,"",$can_alter,undef);
	    $n++;
	}
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles"),
	        $cgi->hr
	 );
}

sub format_existing_roles {
    my($fig,$cgi,$html,$subsystem,$tab,$nP,$can_alter,$reactions,$roles) = @_;
    my($role);

    foreach $role (@$roles)
    {
	&format_role($fig,$cgi,$html,$subsystem,$tab,$$nP,$role,$can_alter,$reactions);
	$$nP++;
    }
}

sub format_role {
    my($fig,$cgi,$html,$subsystem,$tab,$n,$role,$can_alter,$reactions) = @_;
    my($abbrev,$reactT);

    my $react = $reactions ? join(",", map { &HTML::reaction_link($_) } @{$reactions->{$role}}) : "";

    $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($role)) : "";

    my($posT,$abbrevT,$roleT);
    if ($can_alter)
    {
	$posT    = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1);
	$abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
	$roleT   = $cgi->textfield(-name => "role$n", -size => 80, -value => $role, -override => 1);
	$reactT  = $cgi->textfield(-name => "react$n", -size => 20, -value => "", -override => 1);
    }
    else
    {
	push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1),
		    $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1),
	            $cgi->hidden(-name => "role$n", -value => $role, -override => 1));
	$posT = $n;
	$abbrevT = $abbrev;
	$roleT = $role;
    }
    #
    # Wrap the first element in the table with a <A NAME="role_rolename"> tag
    # so we can zing to it from elsewhere. We remove any non-alphanumeric
    # chars in the role name.
    #

    my $posT_html;
    {
	my $rn = $role;
	$rn =~ s/[ \/]/_/g;
	$rn =~ s/\W//g;

	$posT_html = "<a name=\"$rn\">$posT</a>";
    }
    
    my $row = [$posT_html,$abbrevT,$roleT];
    if ($can_alter)
    {
	push(@$row,$react);
	push(@$row,$reactT);
    }
    elsif ($reactions)
    {
	push(@$row,$react);
    }
    push(@$tab,$row);

    if ($cgi->param('check_problems'))
    {
	my @roles    = grep { $_->[0] ne $role } &gene_functions_in_col($fig,$role,$subsystem);
	my($x,$peg);
	foreach $x (@roles)
	{
	    push(@$tab,["","",$x->[0]]);
	    push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
	}
    }
}

sub gene_functions_in_col {
    my($fig,$role,$subsystem) = @_;
    my(%roles,$peg,$func);
   
   
    # RAE this is dying if $subsystem->get_col($subsystem->get_role_index($role) + 1) is not defined
    # it is also not returning the right answer, so we need to fix it.
    # I am not sure why this is incremented by one here (see the note) because it is not right
    # and if you don't increment it by one it is right.
    
                                            # incr by 1 to get col indexed from 1 (not 0)
    #my @pegs = map { @$_ } @{$subsystem->get_col($subsystem->get_role_index($role) + 1)}; 
    
    return undef unless ($role); # this takes care of one error
    my $col_role=$subsystem->get_col($subsystem->get_role_index($role));
    return undef unless (defined $col_role);
    my @pegs = map { @$_ } @$col_role;

    foreach $peg (@pegs)
    {
	if ($func = $fig->function_of($peg))
	{
	    push(@{$roles{$func}},$peg);
	}
    }
    return map { [$_,$roles{$_}] } sort keys(%roles);
}

sub format_subsets {
    my($fig,$cgi,$html,$subsystem,$can_alter) = @_;

    &format_subsetsC($fig,$cgi,$html,$subsystem,$can_alter);
    &format_subsetsR($fig,$cgi,$html,$subsystem);
}

sub format_subsetsC {
    my($fig,$cgi,$html,$subsystem,$can_alter) = @_;

    my $col_hdrs = ["Subset","Includes These Roles"];
    my $tab = [];

    my $n = 1;
    &format_existing_subsetsC($cgi,$html,$subsystem,$tab,\$n,$can_alter);

    if ($can_alter)
    {
	my $i;
	for ($i=0; ($i < 5); $i++)
	{
	    &format_subsetC($cgi,$html,$subsystem,$tab,$n,"");
	    $n++;
	}
    }

    push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles"),
	        $cgi->hr
	 );

    my @subset_names = $subsystem->get_subset_namesC;
    if (@subset_names > 1)
    {
	my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
	push(@$html,$cgi->scrolling_list(-name => 'active_subsetC',
					 -values => [@subset_names],
					 -default => $active_subsetC
					 ),
	            $cgi->br
	     );
    }
    else
    {
	push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => 'All', -override => 1));
    }
}

sub format_subsetsR {
    my($fig,$cgi,$html,$subsystem) = @_;
    my($i);

    my $link = &tree_link;
    push(@$html,$cgi->br,$link,$cgi->br);

    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR;
    push(@$html,$cgi->scrolling_list(-name => 'active_subsetR',
				     -values => ["All",@tmp],
				     -default => $active_subsetR,
				     -size => 5
				     ),
	        $cgi->br
	 );
}

sub format_existing_subsetsC {
    my($cgi,$html,$subsystem,$tab,$nP,$can_alter) = @_;
    my($nameCS);

    foreach $nameCS (sort $subsystem->get_subset_namesC)
    {
	if ($nameCS !~ /all/i)
	{
	    &format_subsetC($cgi,$html,$subsystem,$tab,$$nP,$nameCS);
	    $$nP++;
	}
    }
}

sub format_subsetC {
    my($cgi,$html,$subsystem,$tab,$n,$nameCS) = @_;

    if ($nameCS ne "All")
    {
	my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC_roles($nameCS)) : "";

	$nameCS = $subset ? $nameCS : "";

	my($posT,$subsetT);

	$posT    = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1);
	$subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
	push(@$tab,[$posT,$subsetT]);
    }
}


#
# Handle changes to diagrams.
#

sub handle_diagram_changes
{
    my($fig, $subsystem, $cgi, $html) = @_;
    my $changed;

    return unless $cgi->param("diagram_action");

    my @actions = grep { /^diagram_/ } $cgi->param();

    for my $action (@actions)
    {
	my $value = $cgi->param($action);
	warn "Diagram action $action: $value\n";
	if ($action =~ /^diagram_delete_(\S+)/ and $value eq "on")
	{
	    $subsystem->delete_diagram($1);
	    $changed++;
	}
	elsif ($action =~ /^diagram_rename_(\S+)/ and $value ne "")
	{
	    $subsystem->rename_diagram($1, $value);
	    $changed++;
	}
    }

    my $fh = $cgi->upload("diagram_image_file");

    if ($fh)
    {
	$subsystem->create_new_diagram($fh, $cgi->param("diagram_new_name"));
	$changed++;
    }

    $subsystem->incr_version() if $changed;
}

#
# Format the list of diagrams that a subsystem has.
#

sub format_diagrams
{
    my($fig, $cgi, $html, $subsystem, $can_alter) = @_;

    my @diagrams = $subsystem->get_diagrams();

    if (@diagrams or $can_alter)
    {
	push(@$html, $cgi->hr, $cgi->h2("Subsystem Diagrams"));
    }

    if (@diagrams)
    {
	my @hdr = ("Diagram Name");

	if ($can_alter)
	{
	    push(@hdr, "Delete", "Rename");
	}
	
	my @tbl;
	for my $dent (@diagrams)
	{
	    my($id, $name, $link) = @$dent;
	    my @row;

	    push(@row, qq(<a href="$link" target="show_ss_diagram_$id">$name</a>));

	    if ($can_alter)
	    {
		push(@row, $cgi->checkbox(-name => "diagram_delete_$id", -label => "",
					  -value => undef,
					  -override => 1));
		push(@row, $cgi->textfield(-name => "diagram_rename_$id",
					   -value => "",
					   -override => 1));
	    }
	    
	    push(@tbl, \@row);
	}
	push(@$html, &HTML::make_table(\@hdr, \@tbl));
    }

    if ($can_alter)
    {
	my @tbl;

	push(@tbl, ["Diagram name:", $cgi->textfield(-name => "diagram_new_name",
						     -value => "",
						     -override => 1,
						     -size => 30)]);
	push(@tbl, ["Diagram image file:", $cgi->filefield(-name => "diagram_image_file",
							   -size => 50)]);
	push(@$html, &HTML::make_table(undef, \@tbl));
	
	push(@$html, $cgi->submit(-name => 'diagram_action',
				  -label => 'Process diagram actions'));
    }
    push(@$html, $cgi->hr);
}

sub tree_link {
    my $target = "window$$";
    my $url = &FIG::cgi_url . "/subsys_hope.cgi?request=show_tree";
    return "<a href=$url target=$target>Show Phylogenetic Tree</a>";
}


#  There is a lot of blood, sweat and tears that go into computing the active
#  set of rows.  This is useful information to have later, when the user can
#  select genomes to be checked.  We will return the genome list as a reference
#  to a list of [ genomme_number => name ] pairs. -- GJO

sub format_rows {
    my($fig,$cgi,$html,$subsystem, $tagvalcolor) = @_;
    my($i,%alternatives);
    my $active_genome_list = [];

    my $ignore_alt = $cgi->param('ignore_alt');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    # RAE:
    # added this to allow determination of an active_subsetR based on a tag value pair
    if ($cgi->param('active_key')) 
    { 
        $active_subsetR = $cgi->param('active_key');
	my $active_value = undef;
	$active_value = $cgi->param('active_value') if ($cgi->param('active_value'));
	$subsystem->load_row_subsets_by_kv($active_subsetR, $active_value);
	$subsystem->set_active_subsetR($active_subsetR);
    }

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);
    my %activeR = map { $_ => 1 } @subsetR;

    if (! $ignore_alt)
    {
	my $subset;
	foreach $subset (grep { $_ =~ /^\*/ } $subsystem->get_subset_namesC)
	{
	    my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($subset);
	    if (@mem > 1)
	    {
		my $mem = [@mem];
		foreach $_ (@mem)
		{
		    $alternatives{$_} = [$subset,$mem];
		}
	    }
	}
    }

    my @in = $subsystem->get_genomes;
    
    if (@in > 0)
    {
	my $col_hdrs = ["Genome ID","Organism","Variant Code"];

	if ($cgi->param('color_by_ga')) {push @{$col_hdrs}, "Attribute"}

	my @row_guide = ();

	#  Add pop-up tool tip with role name to abbreviations in column header
	#  (a wonderful suggestion from Carl Woese). -- GJO

	my( $role, %in_col, $abbrev, $mem, $abbrev_html );
	foreach $role (grep { $activeC{$_} } $subsystem->get_roles)
	{
	    if ( ! $in_col{ $role } )  #  Make sure the role is not already done
	    {
		if ( $_ = $alternatives{ $role } )
		{
		    ( $abbrev, $mem ) = @$_;
		    push( @row_guide, [ map { [ $_, "-" . ($subsystem->get_role_index($_) + 1) ] } @$mem ] );
		    foreach $_ ( @$mem ) { $in_col{ $_ } = 1 };  #  Mark the roles that are done
		    my $rolelist = join '<br>', map { substr($_->[1],1) . ". $_->[0]" } @{$row_guide[-1]};
		    $abbrev_html = "<a " . FIGjs::mouseover("Roles of $abbrev", $rolelist, '') . ">$abbrev</a>";
		    push( @$col_hdrs, $abbrev_html );
		}
		else
		{
		    push( @row_guide, [ [ $role, "" ] ] );  #  No suffix on peg number
		    $abbrev = $subsystem->get_role_abbr( $subsystem->get_role_index( $role ) );
		    $abbrev_html = "<a " . FIGjs::mouseover("Role of $abbrev", $role, '') . ">$abbrev</a>";
		    push( @$col_hdrs, $abbrev_html );
		}
	    }
	}

	my $tab = [];
	my($genome,@pegs,@cells,$set,$peg_set,$pair,$role,$suffix,$row,$peg,$color_of,$cell,%count,$color,@colors);

	#
	#  Simplified code for checking variants -- GJO
	#  If specific variants are requested, make a hash of those to keep:
	#
	my $variant_list = undef;
	if ( $cgi->param( 'include_these_variants' ) )
	{
	    $variant_list = { map { ($_, 1) } split( /\s*,\s*/, $cgi->param( 'include_these_variants' ) ) };
	}
	
	foreach $genome (grep { $activeR{$_} } @in)
	{
	    my($genomeV,$vcodeV,$vcode_value);

	    #  Get (and if necessary check) the variant code:

	    $vcode_value = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) );
	    next if ( $variant_list && ( ! $variant_list->{ $vcode_value } ) );

	    $row = [ $genome, &ext_genus_species($fig,$genome), $vcode_value ];
	    push @$active_genome_list, [ $row->[0], $row->[1] ];   #  Save a list of the active genomes

	    @pegs = ();
	    @cells = ();

	    foreach $set (@row_guide)
	    {
		$peg_set = [];
		foreach $pair (@$set)
		{
		    ($role,$suffix) = @$pair;
		    foreach $peg ($subsystem->get_pegs_from_cell($genome,$role))
		    {
			push(@$peg_set,[$peg,$suffix]);
		    }
		}
		push(@pegs,map { $_->[0] } @$peg_set);
		push(@cells,$peg_set);
	    }
	    $color_of = &group_by_clusters($fig,\@pegs);
	    # RAE added a new call to get tag/value pairs
	    # Note that $color_of is not overwritten.
	    my $superscript;
	    if ($cgi->param('color_by_ga')) 
	    {
               # add colors based on the genome attributes
	       # get the value
	       my $ga=$cgi->param('color_by_ga');
	       my $valuetype=$fig->guess_value_format($ga);
	       my @array=$fig->get_attributes($genome, $ga);
	       unless ($array[0]) {$array[0]=[]}
	       # for the purposes of this page, we are going to color on the 
	       # value of the last attribute
	       my ($gotpeg, $gottag, $value, $url)=@{$array[0]};
               if (defined $value) # we don't want to color undefined values
	       {
	          my @color=&cool_colors();
	          my $colval; # what we are basing the color on.
	          if ($valuetype->[0] eq "string") {$colval=$value} # strings are easy, we color based on string;
	          else {
		    # Initially spllit numbers into groups of 10.
		    # $valuetype->[2] is the maximum number for this value
		    # but I don't like this
		    # $colval = int($value/$valuetype->[2]*10);
		    
		    # we want something like 0-1, 1-2, 2-3, 3-4 as the labels.
		    # so we will do it in groups of ten
		    my ($type, $min, $max)=@$valuetype;
		    for (my $i=$min; $i<$max; $i+=$max/10) {
		     if ($value >= $i && $value < $i+$max/10) {$colval = $i . "-" . ($i+($max/10))}
		    }
	          }
                  
	          if (!$tagvalcolor->{$colval}) {
	            # figure out the highest number used in the array
		    $tagvalcolor->{$colval}=0;
		    foreach my $t (keys %$tagvalcolor) {
		      ($tagvalcolor->{$t} > $tagvalcolor->{$colval}) ? $tagvalcolor->{$colval}=$tagvalcolor->{$t} : 1;
		    }
		    $tagvalcolor->{$colval}++;
	          }
		 
		  # RAE Add a column for the description
		  splice @$row, 3, 0, $colval;

	          foreach my $cell (@cells) {
		    foreach $_ (@$cell)
		      {
		        $color_of->{$_->[0]} = $color[$tagvalcolor->{$colval}]
		      }
	          }
	       }
	       else 
	       {
	        # RAE Add a column for the description
		splice @$row, 3, 0, " &nbsp; ";
	       }
	    }
            if ($cgi->param("color_by_peg_tag")) 
	    {
	     ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, \@pegs, $color_of, $tagvalcolor, $cgi->param("color_by_peg_tag"));
	    }
	    foreach $cell ( @cells )  #  $cell = [peg, suffix]
	    {
		#  Deal with the trivial case (no pegs) at the start
		
		if ( ! @$cell )
		{
		    #  Push an empty cell onto the row

		    push @$row, '@bgcolor="#FFFFFF": &nbsp; ';
		    next;
		}

		#  Figure out html text for each peg and cluster by color.

		my ( $peg, $suffix, $txt, $color );
		my @colors = ();
		my %text_by_color;   #  Gather like-colored peg text
		foreach ( @$cell )
		{
		    ( $peg, $suffix ) = @$_;
		    #  Hyperlink each peg, and add its suffix:
		    $txt = ( $cgi->param('ext_ids') ? external_id($fig,$cgi,$peg)
		                                    : HTML::fid_link($cgi,$peg, "local") )
		         . ( $suffix ? $suffix : '' );
		    $color = $color_of->{ $peg };
		    defined( $text_by_color{ $color } ) or push @colors, $color;
		    push @{ $text_by_color{ $color } }, $txt;
		}
		my $ncolors = @colors;

		#  Join text strings within a color (and remove last comma):

		my @str_by_color = map { [ $_, join( ', ', @{ $text_by_color{$_} }, '' ) ] } @colors;
		$str_by_color[-1]->[1] =~ s/, $//;

		#  Build the "superscript" string:

		my $sscript = "";
		if ( $superscript && @$cell )
		{
		    my ( %sscript, $ss );
		    foreach my $cv ( @$cell )  #  Should this be flattened across all pegs?
		    {
			next unless ( $ss = $superscript->{ $cv->[0] } );
			# my %flatten = map { ( $_, 1 ) } @$ss;
			# $sscript{ join ",", sort { $a <=> $b } keys %flatten } = 1;  #  string of all values for peg
			foreach ( @$ss ) { $sscript{ $_ } = 1 }
		    }
		    if (scalar keys %sscript)  # order by number, and format
		    {
			my @ss = map  { $_->[0] }
			         sort { $a->[1] <=> $b->[1] } 
			         map  { my ( $num ) = $_ =~ /\>(\d+)\</; [ $_, $num || 0 ] } keys %sscript;
			$sscript = "&nbsp;<sup>[" . join( ", ", @ss ) . "]</sup>"
		    }
		}

		my $cell_data;

		#  If there is one color, just write a unicolor cell.

		if ( $ncolors == 1 )
		{
		    my ( $color, $txt ) = @{ shift @str_by_color };
		    $cell_data = qq(\@bgcolor="$color":) . $txt . $sscript;
		}

		#  Otherwise, write pegs into a subtable with one cell per color.

		else
		{
		    $cell_data = '<table><tr valign=bottom>'
		               . join( '', map { ( $color, $txt ) = @$_ ; qq(<td bgcolor="$color">$txt</td>) } @str_by_color )
		               . ( $sscript ? "<td>$sscript</td>" : '' )
		               . '</tr></table>';
		}

		#  Push the cell data onto the row:

	        push(@$row, $cell_data);
	    }
	    push(@$tab,$row);
	}


	my($sort);
	if ($sort = $cgi->param('sort'))
	{
	    if ($sort eq "by_pattern")
	    {
		my @tmp = ();
		my $row;
		foreach $row (@$tab)
		{
		    my @var = ();
		    my $i;
		    for ($i=3; ($i < @$row); $i++)
		    {
			push(@var, ($row->[$i] =~ /\|/) ? 1 : 0);
		    }
		    push(@tmp,[join("",@var),$row]);
		}
		$tab = [map { $_->[1] } sort { $a->[0] cmp $b->[0] } @tmp];
	    }
	    elsif ($sort eq "by_phylo")
	    {
		$tab = [map      { $_->[0] }
		        sort     { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
	                map      { [$_, $fig->taxonomy_of($_->[0])] }
		        @$tab];
	    }
	    elsif ($sort eq "by_tax_id")
	    {
		$tab = [sort     { $a->[0] <=> $b->[0] } @$tab];
	    }
	    elsif ($sort eq "alphabetic")
	    {
		$tab = [sort     { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @$tab];
	    }
	    elsif ($sort eq "by_variant")
	    {
		$tab = [sort     { ($a->[2] cmp $b->[2]) or ($a->[1] <=> $b->[1]) } @$tab];
	    }
	}

       	foreach $row (@$tab)
	{
	    next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked
	    my($genomeV,$vcodeV,$vcode_value);
	    $genome = $row->[0];
	    $vcode_value = $row->[2];
	    if ($cgi->param('can_alter'))
	    {
		$genomeV = $cgi->textfield(-name => "genome$genome", -size => 15, -value => $genome, -override => 1);
		$vcodeV  = $cgi->textfield(-name => "vcode$genome", -value => $vcode_value, -size => 10);
	    }
	    else
	    {
		push(@$html,$cgi->hidden(-name => "genome$genome", -value => $genome, -override => 1),
			    $cgi->hidden(-name => "vcode$genome", -value => $vcode_value));
		$genomeV = $genome;
		$vcodeV  = $vcode_value;
	    }
	    $row->[0] = $genomeV;
	    $row->[2] = $vcodeV;
	}

	my $tab1 = [];
  	
	foreach $row (@$tab)
	{
	    next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked
	    if ((@$tab1 > 0) && ((@$tab1 % 10) == 0))
	    {
		push(@$tab1,[map { "<b>$_</b>" } @$col_hdrs]) ;
	    }
	    push(@$tab1,$row);
	}

	push(@$html,&HTML::make_table($col_hdrs,$tab1,"Basic Spreadsheet"),
	            $cgi->hr
	     );

	push(@$html,$cgi->scrolling_list(-name => 'sort', 
					 -value => ['unsorted','alphabetic','by_pattern',
						    'by_phylo','by_tax_id','by_variant'],
					 -default => 'unsorted'
					 ));
      
        push(@$html,'<br><br>Enter comma-separated list of variants to display in spreadsheet<br>', 
                $cgi->textfield(-name => "include_these_variants", -size => 50)
	  );
      }

    # add an explanation for the colors if we want one.
    if ($cgi->param('color_by_ga'))
    {
     push(@$html, &HTML::make_table(undef,&describe_colors($tagvalcolor),"Color Descriptions<br><small>Link limits display to those organisms</small>"));
    }

    return $active_genome_list;  # [ [ id1, gs1 ], [ id2, gs2 ], ... ]
}


sub group_by_clusters {
    my($fig,$pegs) = @_;
    my($peg,@clusters,@cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i);

    my $color_of = {};
    foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }

    if ($cgi->param('show_clusters'))
    {
	@pegs = keys(%$color_of);  #  Use of keys makes @pegs entries unique

	foreach $peg (@pegs)
	{
	    foreach $peg1 (grep { $color_of->{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000))
	    {
		push(@{$conn{$peg}},$peg1);
	    }
	}

	@clusters = ();
	while ($peg = shift @pegs)
	{
	    if (! $seen{$peg})
	    {
		@cluster = ($peg);
		$seen{$peg} = 1;
		for ($i=0; ($i < @cluster); $i++)
		{
		    $x = $conn{$cluster[$i]};
		    foreach $peg1 (@$x)
		    {
			if (! $seen{$peg1})
			{
			    push(@cluster,$peg1);
			    $seen{$peg1} = 1;
			}
		    }
		}
		push(@clusters,[@cluster]);
	    }
	}

	@colors =  &cool_colors();

	@clusters = grep { @$_ > 1 } sort { @$a <=> @$b } @clusters;

	if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) }  # make sure we have enough colors

	my($cluster);
	foreach $cluster (@clusters)
	{
	    $color = shift @colors;
	    foreach $peg (@$cluster)
	    {
		$color_of->{$peg} = $color;
	    }
	}
    }
    return $color_of;
}


=head1 color_by_tag

 Change the color of cells by the pir superfamily. This is taken from the key/value pair
 Note that we will not change the color if $cgi->param('show_clusters') is set.

 This is gneric and takes the following arguments:
 fig, 
 pointer to list of pegs,
 pointer to hash of colors by peg,
 pointer to a hash that retains numbers across rows. The number is based on the value.
 tag to use in encoding

 eg. ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, $pegs, $color_of, $tagvalcolor, "PIRSF");
 
=cut

sub color_by_tag {
 # RAE added this so we can color individual cells across a column
 my ($fig, $pegs, $color_of, $tagvalcolor, $want)=@_;
 # figure out the colors and the superscripts for the pirsf
 # superscript will be a number
 # color will be related to the number somehow
 # url will be the url for each number
 my $number; my $url;
 my $count=0;
 #count has to be the highest number if we increment it
 foreach my $t (keys %$tagvalcolor) {($tagvalcolor->{$t} > $count) ? $count=$tagvalcolor->{$t} : 1}
 $count++; # this should now be the next number to assign
 foreach my $peg (@$pegs) {
  next unless (my @attr=$fig->get_attributes($peg));
  foreach my $attr (@attr) {
   next unless (defined $attr);
   my ($gotpeg, $tag, $val, $link)=@$attr;
   next unless ($tag eq $want);
   if ($tagvalcolor->{$val}) {
    $number->{$peg}=$tagvalcolor->{$val};
    push (@{$url->{$peg}}, "<a href='$link'>" . $number->{$peg} . "</a>");
   }
   else {
    $number->{$peg}=$tagvalcolor->{$val}=$count++;
    push (@{$url->{$peg}}, "<a href='$link'>" . $number->{$peg} . "</a>");
   }
    #### This is a botch at the moment. I want PIRSF to go to my page that I am working on, not PIR
    #### so I am just correcting those. This is not good, and I should change the urls in the tag/value pairs or something
    if ($want eq "PIRSF") {
     pop @{$url->{$peg}};
     $val =~ /(^PIRSF\d+)/;
     push (@{$url->{$peg}}, $cgi->a({href => "pir.cgi?&user=$user&pirsf=$1"}, $number->{$peg}));
    }
  }
 }


 # if we want to assign some colors, lets do so now
 my @colors = &cool_colors(); 
 unless ($cgi->param('show_clusters')) {
  foreach my $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }
  foreach my $peg (keys %$number) {
   # the color is going to be the location in @colors
   unless ($number->{$peg} > @colors) {$color_of->{$peg}=$colors[$number->{$peg}-1]}
  }
 }
 return ($color_of, $url, $tagvalcolor);
}


sub format_ssa_table {
    my($cgi,$html,$user,$ssaP) = @_;
    my($ssa,$curator);
    my($url1,$link1);

    my $can_alter = $cgi->param('can_alter');
    push(@$html, $cgi->start_form(-action => "subsys_hope.cgi",
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
	 );
    push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their
	         user ID), and <b>never open multiple windows to
                 process the same spreadsheet</b></font>.  It is, of course, standard practice to open a subsystem 
                 spreadsheet and then to have multiple other SEED windows to access data and modify annotations.  Further,
	         you can access someone else's subsystem spreadsheet using your ID (which will make it impossible
                 for you to edit the spreadsheet).
                 Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously.
		 A gray color means that the subsystem has no genomes attached to it. Go ahead and make these your own\n",
		 "<a href=\"/FIG/Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a>\n",
	 $cgi->br,
	 $cgi->br
        );

# RAE: removed this from above push because VV want's it kept secret
#		 "<a href=\"/FIG/Html/seedtips.html#change_ownership\" class=\"help\" target=\"help\">Help on changing subsystem ownership</a>\n",

# RAE: Added a new cgi param colsort for sort by column. This url will just recall the script with username to allow column sorting.
# RAE: Added a column to allow indexing of one subsystem. This is also going to be used in the renaming of a subsystem, too

    my $col_hdrs = [
		    "<a href='" . &FIG::cgi_url . "/subsys_hope.cgi?user=$user'>Name</a><br><small>Sort by Subsystem</small>",
		    "<a href='" . &FIG::cgi_url . "/subsys_hope.cgi?user=$user&colsort=curator'>Curator</a><br><small>Sort by curator</small>",
		    "Exchangable","Version",
		    "Reset to Previous Timestamp","Delete",
		    "Export Full Subsystem","Export Just Assignments", "Publish to Clearinghouse", "Reindex Subsystem",
		    ];
    my $title    = "Existing Subsystem Annotations";
    my $tab = [];
    foreach $_ (@$ssaP)
    {
	my($publish_checkbox, $index_checkbox);
	($ssa,$curator) = @$_;

	my $esc_ssa = uri_escape($ssa);

	my($url,$link);
	if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $cgi->param('user')))
	{
	    $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=reset";
	    $link = "<a href=$url>reset</a>";
	}
	else
	{
	    $link = "";
	}

	if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $cgi->param('user')))
	{
	    $url1  = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=make_unexchangable";
	    $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
	}
	elsif ($curator eq $cgi->param('user'))
	{
	    $url1  = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=make_exchangable";
	    $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
	}
	else
	{
	    $link1 = "";
	}

	#
	# Only allow publish for subsystems we are curating?
	#
	if ($curator eq $cgi->param('user'))
	{
	    $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse",
					       -value => $ssa,
					       -label => "Publish");

	}

	#
	# Initially I am going to allow indexing of any subsystem since you may want to index it to allow
	# better searhing on a local system
	$index_checkbox=$cgi->checkbox(-name => "index_subsystem", -value=> $ssa, -label => "Index");

 	# RAE color the background if the subsystem is empty
	# this uses a modification to HTML.pm that I made earlier to accept refs to arrays as cell data
	my $cell1=&ssa_link($fig,$ssa,$user);
	#unless (scalar $fig->subsystem_to_roles($ssa)) {$cell1 = [$cell1, 'td bgcolor="Dark grey"']} ## THIS IS DOG SLOW, BUT WORKS
	#unless (scalar $fig->get_subsystem($ssa)->get_genomes()) {$cell1 = [$cell1, 'td bgcolor="#A9A9A9"']} ## WORKS PERFECTLY, but sort of slow
	unless (scalar @{$fig->subsystem_genomes($ssa, 1)}) {$cell1 = [$cell1, 'td bgcolor="silver"']}

	push(@$tab,[
		    $cell1,
		    $curator,
		    $link1,
	            $fig->subsystem_version($ssa),
		    $link,
		    ($curator eq $cgi->param('user')) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "",
		    $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"),
		    $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"),
		    $publish_checkbox, $index_checkbox,
		    ]);
    }
    push(@$html,
	 &HTML::make_table($col_hdrs,$tab,$title),
	 $cgi->submit(-name => 'delete_export',
		      -label => 'Process marked deletions and exports'),
	 $cgi->submit(-name => 'publish',
		      -label => "Publish marked subsystems"),
         $cgi->submit(-name => 'reindex',
	 	      -label => "Reindex selected subsystems"),
	 $cgi->end_form
	 );
}

# RAE: I think this should be placed as a method in
# Subsystems.pm and called subsystems I know about or something.
# Cowardly didn't do though :-)
sub existing_subsystem_annotations {
    my($fig) = @_;
    my($ssa,$name);
    my @ssa = ();
    if (opendir(SSA,"$FIG_Config::data/Subsystems"))
    {
	@ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,$fig->subsystem_curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
	closedir(SSA);
    }
    # RAE Adding sort of current subsystems
    if ($cgi->param('colsort') && $cgi->param('colsort') eq "curator")
    {
     # sort by the ss curator
     return sort { (lc $a->[1]) cmp (lc $b->[1]) || (lc $a->[0]) cmp (lc $b->[0]) } @ssa;
    } 
    else 
    {
     return sort { (lc $a->[0]) cmp (lc $b->[0]) } @ssa;
    }
}

sub ssa_link {
    my($fig,$ssa,$user) = @_;
    my $name = $ssa; $name =~ s/_/ /g;
    my $target = "window$$";
    if ($name =~ /([a-zA-Z]{3})/)
    {
	$target .= ".$1";
    }

    my $check;
    my $can_alter = $check = $fig->subsystem_curator($ssa) eq $user;

    my $esc_ssa = uri_escape($ssa);
    my $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=show_ssa&can_alter=$can_alter&check=$check&sort=by_phylo&show_clusters=1";
    return "<a href=$url target=$target>$name</a>";
}

sub log_update {
    my($ssa,$user) = @_;

    $ssa =~ s/[ \/]/_/g;

    if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log"))
    {
	my $time = time;
	print LOG "$time\t$user\tupdated\n";
	close(LOG);
    }
    else
    {
	print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n";
    }
}

sub export {
    my($fig,$cgi,$ssa) = @_;
    my($line);

    my ($exportable,$notes) = $fig->exportable_subsystem($ssa);
    foreach $line (@$exportable,@$notes)
    {
	print $line;
    }
}
	
sub export_assignments {
    my($fig,$cgi,$ssa) = @_;
    my(@roles,$i,$entry,$id,$user);

    if (($user = $cgi->param('user')) && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
    {
	$user =~ s/^master://;
	&FIG::verify_dir("$FIG_Config::data/Assignments/$user");
	my $who = $fig->subsystem_curator($ssa);
	my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa";
	
	if (open(OUT,">$FIG_Config::data/Assignments/$user/$file"))
	{
	    while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) 
	    {
		chop;
		push(@roles,$_);
	    }
	    while (defined($_ = <SSA>) && ($_ !~ /^\/\//))	{}
	    while (defined($_ = <SSA>))
	    {
		chop;
		my @flds = split(/\t/,$_);
		my $genome = $flds[0];
		for ($i=2; ($i < @flds); $i++)
		{
		    my @entries = split(/,/,$flds[$i]);
		    foreach $id (@entries)
		    {
			my $peg = "fig|$genome.peg.$id";
			my $func = $fig->function_of($peg);
			print OUT "$peg\t$func\n";
		    }
		}
	    }
	    close(OUT);
	}
	close(SSA);
    }
}

sub format_missing {
    my($fig,$cgi,$html,$subsystem) = @_;
    my($org,$abr,$role,$missing);

    $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
    my($set,$col,%in);
    foreach $set (@alt_sets) 
    {
	my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set);
	foreach $col (@mem)
	{
	    $in{$col} = $set;
	}
    }
    push(@$html,$cgi->h1('To Check Missing Entries:'));

    foreach $org (@subsetR)
    {
	my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);

	$missing = [];
	foreach $role (@missing)
	{
	    $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
	    my $roleE = $cgi->escape($role);
	    
	    my $link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>";
	    push(@$missing,$link);
	}

	if (@$missing > 0)
	{
	    my $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($missing)));
	}
    }
}

sub columns_missing_entries {
    my($cgi,$subsystem,$org,$roles,$in) = @_;

    my $just_genome = $cgi->param('just_genome');
    if ($just_genome && ($just_genome =~ /(\d+\.\d+)/) && ($org != $1)) { return () }

    my $just_col = $cgi->param('just_col');
    my(@really_missing) = ();

    my($role,%missing_cols);
    foreach $role (@$roles)
    {
	next if ($just_col && ($role ne $just_col));
	if ($subsystem->get_pegs_from_cell($org,$role) == 0)
	{
	    $missing_cols{$role} = 1;
	}
    }

    foreach $role (@$roles)
    {
	if ($missing_cols{$role})
	{
	    my($set);
	    if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
	    {
		my @set = $subsystem->get_subsetC_roles($set);

		my($k);
		for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
		if ($k == @set)
		{
		    push(@really_missing,$role);
		}
	    }
	    else
	    {
		push(@really_missing,$role);
	    }
	}
    }
    return @really_missing;
}

sub format_missing_including_matches 
{
    my($fig,$cgi,$html,$subsystem) = @_;
    my($org,$abr,$role,$missing);

    my $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
    my($set,$col,%in);
    foreach $set (@alt_sets) 
    {
	my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set);
	foreach $col (@mem)
	{
	    $in{$col} = $set;
	}
    }
    push(@$html,$cgi->h1('To Check Missing Entries:'));

    push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));

    my $can_alter = $cgi->param('can_alter');
    push(@$html,
	 $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	 $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));

    my $just_role = &which_role($subsystem,$cgi->param('just_role'));
#   print STDERR "There are ", scalar @subsetR, " organisms to check\n";
    foreach $org (@subsetR)
    {
	my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
	$missing = [];
	foreach $role (@missing)
	{
#	    next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1)));
	    next if ($just_role && ($just_role ne $role));

	    my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));
	    push(@$missing,@hits);
	}
#       print STDERR "Found ", scalar @$missing, " for $org\n";
	if (@$missing > 0)
	{
	    my $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));

	    my $colhdr = ["Assign", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
	    my $tbl = [];
	    
	    for my $hit (@$missing)
	    {
		my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit;

		my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
		my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);

		my $checkbox = $cgi->checkbox(-name => "checked",
					      -value => "to=$my_peg,from=$match_peg",
					      -label => "");

		push(@$tbl, [$checkbox,
			     $psc,
			     $my_peg_link, $my_len, $my_fn,
			     $match_peg_link, $match_len, $match_fn]);
	    }

	    push(@$html, &HTML::make_table($colhdr, $tbl, ""));
	}
    }
    push(@$html,
	 $cgi->submit(-value => "Process assignments",
			      -name => "batch_assign"),
	 $cgi->end_form);
}



sub columns_missing_entries {
    my($cgi,$subsystem,$org,$roles,$in) = @_;

    next if (($_ = $cgi->param('just_genome')) && ($org != $_));
    my $just_col = $cgi->param('just_col');
    my(@really_missing) = ();

    my($role,%missing_cols);
    foreach $role (@$roles)
    {
	next if ($just_col && ($role ne $just_col));
	if ($subsystem->get_pegs_from_cell($org,$role) == 0)
	{
	    $missing_cols{$role} = 1;
	}
    }

    foreach $role (@$roles)
    {
	if ($missing_cols{$role})
	{
	    my($set);
	    if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
	    {
		my @set = $subsystem->get_subsetC_roles($set);

		my($k);
		for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
		if ($k == @set)
		{
		    push(@really_missing,$role);
		}
	    }
	    else
	    {
		push(@really_missing,$role);
	    }
	}
    }
    return @really_missing;
}

sub format_missing_including_matches_in_ss 
{
    my($fig,$cgi,$html,$subsystem) = @_;
    my($org,$abr,$role,$missing);

    my $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
    my($set,$col,%in);
    foreach $set (@alt_sets) 
    {
	my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set);
	foreach $col (@mem)
	{
	    $in{$col} = $set;
	}
    }
    push(@$html,$cgi->h1('To Check Missing Entries:'));

    push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));

    my $can_alter = $cgi->param('can_alter');
    push(@$html,
	 $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	 $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));

    my $just_role = &which_role($subsystem,$cgi->param('just_role'));
    
    foreach $org (@subsetR)
    {
	my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
	$missing = [];
	foreach $role (@missing)
	{
#	    next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1)));
	    next if ($just_role && ($just_role ne $role));

            my $flag = 0;
            my $filler;
            my $rdbH = $fig->db_handle;
            my $q = "SELECT subsystem, role FROM subsystem_index WHERE role = ?";
            if (my $relational_db_response = $rdbH->SQL($q, 0, $role))
            {
             	my $pair;
                foreach $pair (@$relational_db_response)
                {
                     my ($ss, $role) = @$pair;
                     #if($ss =="")
                     #{
                      # $filler = 1; 
                     #}

                     if ($ss !~/Unique/)
                     {
                        $flag = 1; 
		     }
		}
            } 
            
            if ($flag == 1)
            {    
                my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));
	        push(@$missing,@hits);
	    }
	}

	if (@$missing > 0)
	{
	    my $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));

	    my $colhdr = ["Assign","Sub(s)", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
	    my $tbl = [];
	    
	    for my $hit (@$missing)
	    {
		my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit; 
		my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
		my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);

		my $checkbox = $cgi->checkbox(-name => "checked",
					      -value => "to=$my_peg,from=$match_peg",
					      -label => "");
                my $good = 0;
                my @list_of_ss = ();
                my $ss_table_entry = "none";
                
                my (@list_of_returned_ss,$ss_name,$ss_role);
                @list_of_returned_ss = $fig->subsystems_for_peg($match_peg); 
                if (@list_of_returned_ss > 0)
                { 
                   for my $ret_ss (@list_of_returned_ss)
                   {
                      ($ss_name,$ss_role)= @$ret_ss;
                      if ($ss_name !~/Unique/)
                       { 
			   $good = 1;
                       }
                   }
                } 
		
                if ($good)
                {
                 my (@list_of_returned_ss,$ss_name,$ss_role);
                 @list_of_returned_ss = $fig->subsystems_for_peg($my_peg); 
                 if (@list_of_returned_ss > 0)
                 { 
                   for my $ret_ss (@list_of_returned_ss)
                   {
                      ($ss_name,$ss_role)= @$ret_ss;
                      if ($ss_name !~/Unique/)
                       { 
			   push (@list_of_ss,$ss_name);
                           $ss_table_entry = join("<br>",@list_of_ss);
                           
                       }
                   }
                }
	    
                push(@$tbl, [$checkbox,$ss_table_entry,
		$psc,
		$my_peg_link, $my_len, $my_fn,
		$match_peg_link, $match_len, $match_fn]);
              }
               
	    
            }

	    push(@$html, &HTML::make_table($colhdr, $tbl, ""));
	}
    }
    push(@$html,
	 $cgi->submit(-value => "Process assignments",
			      -name => "batch_assign"),
	 $cgi->end_form);
}


sub format_check_assignments {
    my($fig,$cgi,$html,$subsystem) = @_;
    my($org,$role);

    my $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    push(@$html,$cgi->h1('Potentially Bad Assignments:'));

    foreach $org (@subsetR)
    {
	next if (($_ = $cgi->param('just_genome_assignments')) && ($_ != $org));
	my @bad = ();

	foreach $role (@subsetC)
	{
	    next if (($_ = $cgi->param('just_role_assignments')) && ($_ != ($subsystem->get_role_index($role) + 1)));
	    push(@bad,&checked_assignments($cgi,$subsystem,$org,$role));
	}

	if (@bad > 0)
	{
	    my $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"),
		        $cgi->ul($cgi->li(\@bad)));
	    
	}
    }
    push(@$html,$cgi->hr);
}

sub checked_assignments {
    my($cgi,$subsystem,$genome,$role) = @_;
    my($peg,$line1,$line2,@out,$curr,$auto);

    my(@bad) = ();
    my @pegs = $subsystem->get_pegs_from_cell($genome,$role);
    if (@pegs > 0)
    {
	my $tmp = "/tmp/tmp.pegs.$$";
	open(TMP,">$tmp") || die "could not open $tmp";
	foreach $peg (@pegs)
	{
	    print TMP "$peg\n";
	}
	close(TMP);
	my $strict = $cgi->param('strict_check') ? "strict" : "";
	@out = `$FIG_Config::bin/check_peg_assignments $strict < $tmp 2> /dev/null`;
	unlink($tmp);

	while (($_ = shift @out) && ($_ =~ /^(fig\|\d+\.\d+\.peg\.\d+)/))
	{
	    $peg = $1;
	    if (($line1 = shift @out) && ($line1 =~ /^current:\s+(\S.*\S)/) && ($curr = $1) &&
		($line2 = shift @out) && ($line2 =~ /^auto:\s+(\S.*\S)/) && ($auto = $1))
	    {
		if (! $fig->same_func($curr,$auto))
		{
		    my $link = &HTML::fid_link($cgi,$peg);
		    push(@bad,"$link<br>$line1<br>$line2<br><br>");
		}
	    }
	}
    }
    return @bad;
}

sub format_dups {
    my($fig,$cgi,$html,$subsystem) = @_;

    my $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    push(@$html,$cgi->h1('To Check Duplicates:'));

    my($org,$duplicates,$role,$genus_species);
    foreach $org (@subsetR)
    {
	$duplicates = [];
	foreach $role (@subsetC)
	{
	    my(@pegs,$peg,$func);
	    if ((@pegs = $subsystem->get_pegs_from_cell($org,$role)) > 1)
	    {
		push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @pegs])));
	    }
	}

	if (@$duplicates > 0)
	{
	    $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($duplicates)));
	}
    }
}

sub format_coupled {
    my($fig,$cgi,$html,$subsystem,$type) = @_;
    my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2);
    my(@cluster,$sc,$x,$id2,@in,$sim,@coupled);
    my($org,$role);

    $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    foreach $org (@subsetR)
    {
	foreach $role (@subsetC)
	{
	    push(@in,$subsystem->get_pegs_from_cell($org,$role));
	}
    }

    %in = map { $_ => 1 } @in;
    @show = ();
    foreach $peg1 (@in)
    {
	if ($type eq "careful")
	{
	    @coupled = $fig->coupling_and_evidence($peg1,5000,1.0e-10,0.2,1);
	}
	else
	{
	    @coupled = $fig->fast_coupling($peg1,5000,1);
	}

	foreach $x (@coupled)
	{
	    ($sc,$peg2) = @$x;
	    if ((! $in{$peg2}) && ((! $seen{$peg2}) || ($seen{$peg2} < $sc)))
	    {
		$seen{$peg2} = $sc;
#		print STDERR "$sc\t$peg1 -> $peg2\n";
	    }
	}
    }
	
    foreach $peg1 (sort { $seen{$b} <=> $seen{$a} } keys(%seen))
    {
	if (! $seen2{$peg1})
	{
	    @cluster = ($peg1);
	    $seen2{$peg1} = 1;
	    for ($i=0; ($i < @cluster); $i++)
	    {
		foreach $sim ($fig->sims($cluster[$i],1000,1.0e-10,"fig"))
		{
		    $id2 = $sim->id2;
		    if ($seen{$id2} && (! $seen2{$id2}))
		    {
			push(@cluster,$id2);
			$seen2{$id2} = 1;
		    }
		}
	    }
	    push(@show, [scalar @cluster,
			 $cgi->br .
			 $cgi->ul($cgi->li([map { $peg = $_; 
						  $sc = $seen{$peg};
						  $func = $fig->function_of($peg,$user); 
						  $gs = $fig->genus_species($fig->genome_of($peg));
						  $link = &HTML::fid_link($cgi,$peg);
						  "$sc: $link: $func \[$gs\]" } 
					    sort { $seen{$b} <=> $seen{$a} }
					    @cluster]))
			 ]);
	}
    }

    if (@show > 0)
    {
	@show = map { $_->[1] } sort { $b->[0] <=> $a->[0] } @show;
	push(@$html,$cgi->h1('Coupled, but not in Spreadsheet:'));
	push(@$html,$cgi->ul($cgi->li(\@show)));
    }
}

sub ext_genus_species {
    my($fig,$genome) = @_;

    my $gs = $fig->genus_species($genome);
    my $c  = substr($fig->taxonomy_of($genome),0,1);
    return "$gs [$c]";
}
	
sub show_tree {

    my($id,$gs);   
    my($tree,$ids) = $fig->build_tree_of_complete;
    my $relabel = {};
    foreach $id (@$ids)
    {
	if ($gs = $fig->genus_species($id))
	{
	    $relabel->{$id} = "$gs ($id)";
	}
    }
    $_ = &display_tree($tree,$relabel);
    print $cgi->pre($_),"\n";
}

sub export_align_input
{

}

sub annotate_column {
    # RAE: I added this function to allow you to reannotate a single column all at once
    # this is because I wanted to update some of my annotations after looking at UniProt
    # and couldn't see an easy way to do it.
    my($fig,$cgi,$html,$col,$subsystem) = @_;
    my $checked;
    my $roles = [$subsystem->get_roles];
    my $role = &which_role_for_column($col,$roles);
    my @checked = &seqs_to_align($role,$subsystem);
    return undef unless (@checked);
    
    # the following is read from fid_checked.cgi
    push( @$html, "<table border=1>\n",
	           "<tr><td>Protein</td><td>Organism</td><td>Current Function</td><td>By Whom</td></tr>"
	);
    
    foreach my $peg ( @checked ) {
        my @funcs = $fig->function_of( $peg );
        if ( ! @funcs ) { @funcs = ( ["", ""] ) }
        my $nfunc = @funcs;
	my $org = $fig->org_of( $peg );
	push( @$html, "<tr>",
	              "<td rowspan=$nfunc>$peg</td>",
	              "<td rowspan=$nfunc>$org</td>"
	    );
	my ($who, $what);
	push( @$html, join( "</tr>\n<tr>", map { ($who,$what) = @$_; "<td>$what</td><td>$who</td>" } @funcs ) );
	push( @$html, "</tr>\n" );
    }
    push( @$html, "</table>\n" );

    push( @$html, $cgi->start_form(-action => "fid_checked.cgi", -target=>"_blank"),
              $cgi->br, $cgi->br,
              "<table>\n",
              "<tr><td>New Function:</td>",
              "<td>", $cgi->textfield(-name => "function", -size => 60), "</td></tr>",
              "<tr><td colspan=2>", $cgi->hr, "</td></tr>",
              "<tr><td>New Annotation:</td>",
              "<td rowspan=2>", $cgi->textarea(-name => "annotation", -rows => 30, -cols => 60), "</td></tr>",
	      "<tr><td valign=top width=20%><br>", $cgi->submit('add annotation'), 
	      "<p><b>Please note:</b> At the moment you need to make sure that the annotation in the table at the ",
	      "top of this page reflects the new annotation. This may not be updated automatically.</p>",
	      "</td></tr>",
              "</table>",
              $cgi->hidden(-name => 'user', -value => $user),
              $cgi->hidden(-name => 'checked', -value => [@checked]),
              $cgi->end_form
     );
}



sub align_column {
    my($fig,$cgi,$html,$colN,$subsystem) = @_;
    my(@pegs,$peg,$pseq,$role);

    my $roles = [$subsystem->get_roles];
    my $name = $subsystem->get_name;
    &check_index("$FIG_Config::data/Subsystems/$name/Alignments",$roles);
    if (($role = &which_role_for_column($colN,$roles)) &&
	((@pegs = &seqs_to_align($role,$subsystem)) > 1))
    {
	my $tmpF = "/tmp/seqs.fasta.$$";
	open(TMP,">$tmpF") || die "could not open $tmpF";

	foreach $peg (@pegs)
	{
	    if ($pseq = $fig->get_translation($peg))
	    {
		$pseq =~ s/[uU]/x/g;
		print TMP ">$peg\n$pseq\n";
	    }
	}
	close(TMP);

	my $name = $subsystem->get_name;
	my $dir = "$FIG_Config::data/Subsystems/$name/Alignments/$colN";

	if (-d $dir)
	{
	    system "rm -rf \"$dir\"";
	}

	&FIG::run("$FIG_Config::bin/split_and_trim_sequences \"$dir/split_info\" < $tmpF");

	if (-s "$dir/split_info/set.sizes")
	{
	    open(SZ,"<$dir/split_info/set.sizes") || die " could not open $dir/split_info/set.sizes";
	    while (defined($_ = <SZ>))
	    {
		if (($_ =~ /^(\d+)\t(\d+)/) && ($2 > 3))
		{
		    my $n = $1;
		    &FIG::run("$FIG_Config::bin/make_phob_from_seqs \"$dir/$n\" < \"$dir/split_info\"/$n");
		}
	    }
	    close(SZ);
	    &update_index("$FIG_Config::data/Subsystems/$name/Alignments/index",$colN,$role);
	}
	else
	{
	    system("rm -rf \"$dir\"");
	}
    }
}

sub align_subcolumn {
    my($fig,$cgi,$html,$colN,$subcolN,$subsystem) = @_;
    my($role,@pegs,$cutoff,$peg);

    my $name = $subsystem->get_name;
    my $dir = "$FIG_Config::data/Subsystems/$name/Alignments/$colN/$subcolN";
    my $roles = [$subsystem->get_roles];
    if (&check_index("$FIG_Config::data/Subsystems/$name/Alignments",$roles))
    {
	my @pegs = map { $_ =~ /^(\S+)/; $1 } `cut -f2 $dir/ids`;

	if ($cutoff = $cgi->param('include_homo'))
	{
	    my $max = $cgi->param('max_homo');
	    $max = $max ? $max : 100;
	    push(@pegs,&get_homologs($fig,\@pegs,$cutoff,$max));
	}

	system "rm -rf \"$dir\"";
	open(MAKE,"| make_phob_from_ids \"$dir\"") || die "could not make PHOB";
	foreach $peg (@pegs)
	{
	    print MAKE "$peg\n";
	}
	close(MAKE);
    }
}

sub which_role_for_column {
    my($col,$roles) = @_;
    my($i);

    if (($col =~ /^(\d+)/) && ($1 <= @$roles))
    {
	return $roles->[$1-1];
    }
    return undef;
}

sub seqs_to_align {
    my($role,$subsystem) = @_;
    my($genome);

    my @seqs = ();
    foreach $genome ($subsystem->get_genomes)
    {
	push(@seqs,$subsystem->get_pegs_from_cell($genome,$role));
    }
    return @seqs;
}

sub get_homologs {
    my($fig,$checked,$cutoff,$max) = @_;
    my($peg,$sim,$id2);

    my @homologs = ();
    my %got = map { $_ => 1 } @$checked;

    foreach $peg (@$checked)
    {
	foreach $sim ($fig->sims($peg,$max,$cutoff,"fig"))
	{
	    $id2 = $sim->id2;
	    if ((! $got{$id2}) && ($id2 =~ /^fig\|(\d+\.\d+)/) && ($fig->is_complete($1)))
	    {
		push(@homologs,[$sim->psc,$id2]);
		$got{$id2} = 1;
	    }
	}
    }
    @homologs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @homologs;
    if (@homologs > $max) { $#homologs = $max-1 }

    return @homologs;
}

sub set_links {
    my($cgi,$out) = @_;
   
    my @with_links = ();
    foreach $_ (@$out)
    {
	if ($_ =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
	{
	    my($before,$peg,$after) = ($1,$2,$3);
	    push(@with_links, $before . &HTML::fid_link($cgi,$peg) . $after . "\n");
	}
	else
	{
	    push(@with_links,$_);
	}
    }
    return @with_links;
}

sub reset_ssa {
    my($fig,$cgi,$html) = @_;
    my($ssa,@spreadsheets,$col_hdrs,$tab,$t,$readable,$url,$link,@tmp);

    if (($ssa = $cgi->param('ssa_name')) && opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup"))
    {
	@spreadsheets = sort { $b <=> $a }
	                map { $_ =~ /^spreadsheet.(\d+)/; $1 }
			grep { $_ =~ /^spreadsheet/ } 
	                readdir(BACKUP);
	closedir(BACKUP);
	$col_hdrs = ["When","Number Genomes"];
	$tab = [];
	foreach $t (@spreadsheets)
	{
	    $readable = &FIG::epoch_to_readable($t);
	    $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=" . uri_escape( $ssa ) . "&request=reset_to&ts=$t";
	    $link = "<a href=$url>$readable</a>";
	    open(TMP,"<$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t")
		|| die "could not open $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t";
	    $/ = "//\n";
	    $_ = <TMP>;
	    $_ = <TMP>;
	    $_ = <TMP>;
	    chomp;
	    $/ = "\n";

	    @tmp = grep { $_ =~ /^\d+\.\d+/ } split(/\n/,$_);
	    push(@$tab,[$link,scalar @tmp]);
	}
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Possible Points to Reset From"));
}

sub reset_ssa_to {
    my($fig,$cgi,$html) = @_;
    my($ts,$ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 ($ts = $cgi->param('ts')) && 
	 (-s "$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts"))
    {
	system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts $FIG_Config::data/Subsystems/$ssa/spreadsheet";
	chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
	if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts")
	{
	    system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts $FIG_Config::data/Subsystems/$ssa/notes";
	    chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
	}

	if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/reactions.$ts")
	{
	    system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/reactions.$ts $FIG_Config::data/Subsystems/$ssa/reactions";
	    chmod(0777,"$FIG_Config::data/Subsystems/$ssa/reactions");
	}

	my $subsystem = new Subsystem($ssa,$fig,0);
	$subsystem->db_sync(0);
	undef $subsystem;
    }
}
		
sub make_exchangable {
    my($fig,$cgi,$html) = @_;
    my($ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet") &&
	open(TMP,">$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
    {
	print TMP "1\n";
	close(TMP);
	chmod(0777,"$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
    }
}

sub make_unexchangable {
    my($fig,$cgi,$html) = @_;
    my($ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 (-s "$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
    {
	unlink("$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
    }
}

sub which_role {
    my($subsystem,$role_indicator) = @_;
    my($n,$role,$abbr);

    if (($role_indicator =~ /^\s*(\d+)\s*$/) && ($n = $1) && ($role = $subsystem->get_role($n-1)))
    {
	return $role;
    }
    elsif (($role_indicator =~ /^\s*(\S+)\s*$/) && ($abbr = $1) && ($role = $subsystem->get_role_from_abbr($abbr)))
    {
	return $role;
    }
    return "";
}

sub external_id {
    my($fig,$cgi,$peg) = @_;
    my @tmp;
    my @aliases = ($fig->feature_aliases($peg),map { $_->[0] } $fig->mapped_prot_ids($peg));
    if      ((@tmp = grep { $_ =~ /^uni\|/ } @aliases) > 0)
    {
	@aliases = map { &HTML::uni_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^sp\|/ } @aliases) > 0)
    {
	@aliases = map { &HTML::sp_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^gi\|/ } @aliases) > 0)
    {
	@aliases = map { &HTML::gi_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^kegg\|/ } @aliases) > 0)
    {
	@aliases = map { &HTML::kegg_link($cgi,$_) } @tmp;
    }
    else
    {
	return wantarray() ? (&HTML::fid_link($cgi,$peg)) : &HTML::fid_link($cgi,$peg);
    }

    if (wantarray())
    {
	return @aliases;
    }
    else
    {
	return $aliases[0];
    }
}

sub cool_colors {
 # just an array of "websafe" colors or whatever colors we want to use. Feel free to remove bad colors (hence the lines not being equal length!)
 return (
 '#C0C0C0', '#FF40C0', '#FF8040', '#FF0080', '#FFC040', '#40C0FF', '#40FFC0', '#C08080', '#C0FF00', '#00FF80', '#00C040',
 "#6B8E23", "#483D8B", "#2E8B57", "#008000", "#006400", "#800000", "#00FF00", "#7FFFD4",
 "#87CEEB", "#A9A9A9", "#90EE90", "#D2B48C", "#8DBC8F", "#D2691E", "#87CEFA", "#E9967A", "#FFE4C4", "#FFB6C1",
 "#E0FFFF", "#FFA07A", "#DB7093", "#9370DB", "#008B8B", "#FFDEAD", "#DA70D6", "#DCDCDC", "#FF00FF", "#6A5ACD",
 "#00FA9A", "#228B22", "#1E90FF", "#FA8072", "#CD853F", "#DC143C", "#FF6347", "#98FB98", "#4682B4",
 "#D3D3D3", "#7B68EE", "#2F4F4F", "#FF7F50", "#FF69B4", "#BC8F8F", "#A0522D", "#DEB887", "#00DED1",
 "#6495ED", "#800080", "#FFD700", "#F5DEB3", "#66CDAA", "#FF4500", "#4B0082", "#CD5C5C",
 "#EE82EE", "#7CFC00", "#FFFF00", "#191970", "#FFFFE0", "#DDA0DD", "#00BFFF", "#DAA520", "#008080",
 "#00FF7F", "#9400D3", "#BA55D3", "#D8BFD8", "#8B4513", "#3CB371", "#00008B", "#5F9EA0",
 "#4169E1", "#20B2AA", "#8A2BE2", "#ADFF2F", "#556B2F",
 "#F0FFFF", "#B0E0E6", "#FF1493", "#B8860B", "#FF0000", "#F08080", "#7FFF00", "#8B0000",
 "#40E0D0", "#0000CD", "#48D1CC", "#8B008B", "#696969", "#AFEEEE", "#FF8C00", "#EEE8AA", "#A52A2A",
 "#FFE4B5", "#B0C4DE", "#FAF0E6", "#9ACD32", "#B22222", "#FAFAD2", "#808080", "#0000FF",
 "#000080", "#32CD32", "#FFFACD", "#9932CC", "#FFA500", "#F0E68C", "#E6E6FA", "#F4A460", "#C71585",
 "#BDB76B", "#00FFFF", "#FFDAB9", "#ADD8E6", "#778899",
 );
}

sub describe_colors {
 my ($tvc)=@_;
 my $tab = [];
 my @colors=&cool_colors();
 my @labels=sort {$a cmp $b} keys %$tvc;
 my $selfurl=$cgi->url();
 # recreate the url for the link
 $selfurl .= "?user=" . $cgi->param('user')
          .  "&ssa_name=" . uri_escape( $cgi->param('ssa_name') )
          .  "&request=" . $cgi->param('request')
          .  "&can_alter=" . $cgi->param('can_alter');
 
 my $row;
 for (my $i=0; $i<= scalar @labels; $i++) {
  next unless (defined $labels[$i]);
  my $link='<a href="' . $selfurl . "&active_key=" . $cgi->param('color_by_ga') . "&active_value=" . $labels[$i] . '">' . $labels[$i] . "</a>\n";
  push @$row, [$link, "td style=\"background-color: $colors[$tvc->{$labels[$i]}]\""];
  unless (($i+1) % 10) {
   push @$tab, $row;
   undef $row;
  }
 }
 push @$tab, $row;
 return $tab;
}

sub existing_trees {
    my($dir,$roles) = @_;
    my(@rolesI,$roleI,@subrolesI,$subroleI);

    &check_index("$dir/Alignments",$roles);

    my @rolesA = ();

    if (opendir(DIR,"$dir/Alignments"))
    {
	@rolesI = grep { $_ =~ /^(\d+)$/ } readdir(DIR);
	closedir(DIR);

	foreach $roleI (@rolesI)
	{
	    if ((-d "$dir/Alignments/$roleI/split_info") && opendir(SUBDIR,"$dir/Alignments/$roleI"))
	    {
		@subrolesI = grep { $_ =~ /^(\d+)$/ } readdir(SUBDIR);
		closedir(SUBDIR);

		foreach $subroleI (@subrolesI)
		{
		    push(@rolesA,"$roleI.$subroleI: $roles->[$roleI-1]");
		}
	    }
	}
    }

    my($x,$y);
    return [sort { $a =~ /^(\d+\.\d+)/; $x = $1; 
		   $b =~ /^(\d+\.\d+)/; $y = $1;
		   $x <=> $y
		  } @rolesA];
}

sub check_index {
    my($alignments,$roles) = @_;

    if (-s "$alignments/index")
    {
	my $ok = 1;
	foreach $_ (`cat \"$alignments/index\"`)
	{
	    $ok = $ok && (($_ =~ /^(\d+)\t(\S.*\S)/) && ($roles->[$1 - 1] eq $2));
	}
	if (! $ok)
	{
	    system "rm -rf \"$alignments\"";
	    return 0;
	}
	return 1;
    }
    else
    {
	system "rm -rf \"$alignments\"";
    }
    return 0;
}

sub update_index {
    my($file,$colN,$role) = @_;

    my @lines = ();
    if (-s $file)
    {
	@lines = grep { $_ !~ /^$colN\t/ } `cat $file`;
    }
    push(@lines,"$colN\t$role\n");
    open(TMP,">$file") || die "could not open $file";
    foreach $_ (@lines)
    {
	print TMP $_;
    }
    close(TMP);
}

sub show_sequences_in_column {
    my($fig,$cgi,$html,$subsystem,$colN) = @_;
    my(@pegs,$role);

    my $roles = [$subsystem->get_roles];
    if (($role = &which_role_for_column($colN,$roles)) &&
	((@pegs = &seqs_to_align($role,$subsystem)) > 0))
    {
	push(@$html, "<pre>\n");
        foreach my $peg (@pegs)
	{
	    my $seq;
	    if ($seq = $fig->get_translation($peg))
	    {
		push(@$html,  ">$peg\n",&formatted_seq($seq));
	    }
	    else
	    {
		push(@$html, "could not find translation for $peg\n");
	    }
	}
	push(@$html, "\n</pre>\n");
    }
    else
    {
	push(@$html,$cgi->h1("Could not determine the role from $colN"));
    }
}
    
sub formatted_seq {
    my($seq) = @_;
    my($i,$ln);

    my @seqs = ();
    my $n = length($seq);
    for ($i=0; ($i < $n); $i += 60) {
        if (($i + 60) <= $n) {
            $ln = substr($seq,$i,60);
        } else {
            $ln = substr($seq,$i,($n-$i));
        }
	push(@seqs,"$ln\n");
    }
    return @seqs;
}

sub check_ssa {
    my($fig,$cgi) = @_;

    my $user = $cgi->param('user');
    my $ssa  = $cgi->param('ssa_name');
    my $checked;
    if ($user && $ssa)
    {
	$ENV{'REQUEST_METHOD'} = 'GET';
	$ENV{'QUERY_STRING'} = "user=$user&subsystem=$ssa&request=check_ssa";
	$checked = join("",`$FIG_Config::fig/CGI/check_subsys.cgi`);
	if ($checked =~ /^.*?(<form .*form>)/s)
	{
	    return $1;
	}
    }
    return "";
}


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3