#!/usr/bin/perl
# -*- Mode: perl -*-
# file: locus

use lib '/usr/local/gramene/lib/perl/';
use strict;
use vars qw($DB);
use CGI 2.42 qw/:standard :html3 escape *table *TR *td *blockquote/;
use Ace 1.51;
use Ace::Browser::AceSubs qw(:DEFAULT Toggle);
use Ace::Browser::TreeSubs qw(AceImageHackURL);
use GrameneSubs;

use constant CLASS   => 'Locus';
use constant EXAMPLE => 'A-1RM98';

# open the database
$DB = OpenDatabase() || AceError("Couldn't open database.");

my ($obj_name, $obj);
$obj_name = param('name');
$obj = get_obj($obj_name) if $obj_name;

PrintTop($obj,CLASS,$obj ? CLASS . ": $obj" : CLASS . " Search");
PrintWarning($obj_name,CLASS) if $obj_name && !$obj;
PrintPrompt(CLASS, EXAMPLE);
if ($obj) {
  print start_table;
  print start_TR({-valign=>'TOP'}),start_td;
  print_report($obj);
  print end_td,start_td;
  print_image($obj);
  print end_td,end_TR,end_table;
}
PrintBottom();

sub get_obj {
  my $name = shift;
  my ($obj) = $DB->fetch(-class =>CLASS,
			 -name  => $name);
  return $obj;
}

sub print_report {
  my $obj = shift;

  print start_table({-border=>1});
  PrintMultiple('Aliases',$obj->Original_name,$obj->Other_name);

  if (my @a = $obj->Map) {
    my $second = 0;
    print start_TR;
    for my $map (@a) {
      print $second++ ? th({-class=>'datatitle'},'&nbsp;')
                      : th({-class=>'datatitle'},'Map Location');
      my $position  = $map->right(2);
      my $error     = $map->right(4);
      $position .= "+/-$error" if $error;
      $position .= ' cM';
      print td({-class=>'databody'},ObjectLink($map,"Linkage group $map") ." $position");
      print end_TR;
    }
  }
  my $article = $obj->Map_study->Cited_in->Title 
    if defined $obj->Map_study->Cited_in;

  print TR(
	   th({-class=>'datatitle'},'Map Study'),
 	   td({-class=>'databody'},ObjectLink($obj->Map_study) . br . cite($article))
	   );
  PrintMultiple('Marker',$obj->Marker);
  print end_table;

  my $info = $obj->Help ? $obj->Help->Info : '';
  if ( $info ) {
    print br, br;
    if (Toggle('help','Help on locus') ) {
      print pre($info->right);
    }
  }
}

sub print_image {
  my $obj = shift;
  my @images = get_images($obj);

  foreach my $img (@images) {
    my $picture = $img->Pick_me_to_call(2);
    print STDERR "locus: Image $img lacks Pick_me_to_call\n" and next unless $picture;
    print p(a({-href=>AceImageHackURL($picture),
	       -target=>'_new'},
	      img({-src=>AceImageHackURL($picture),
	       -border=>0,
		   -width=>300})));
  }

}


sub get_images {
    my $obj = shift;
    my @marker_images = $DB->fetch(-query=>qq(find locus "$obj"; follow Marker; follow Image));
    my @poly_images   = $DB->fetch(-query=>qq(find locus "$obj"; follow Marker; follow Polymorphism; follow Image));
    return (@marker_images,@poly_images);
}

