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

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

use constant CLASS   => 'Map';
use constant EXAMPLE => 'R1';
use constant NBS     => '&nbsp;';

use constant AQL_ALL => <<END;
select gm,g,pos,g->Marker
    from g in object("Map","%s")->Contains[2],
        gm in g->Map, pos in gm[Position], error in gm[Error]
       where gm = "%s" and pos
          order by :pos asc
END

use constant AQL_MARKERS => <<END;
select g,m,m->Type,m->Forward_primer,m->Reverse_primer,m->size_range,
         m->motif,m->polymorphism,m->trait,m->remarks,m->full_name,
         m->AFLP_Primer[3]
  from g in object("Map","%s")->Contains[2], m in g->Marker
  where m
END

# 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;

if (param('Download Map')) {
  download($obj);
  exit 0;
}

PrintTop($obj,CLASS,$obj ? CLASS . ": $obj" : CLASS . " Search");
PrintWarning($obj_name,CLASS) if $obj_name && !$obj;

if (!param('study') && $obj) {
  my $study = $obj->Map_study;
  param('study' => "$study");
}

print_study(param('study')) if param('study');
print_prompt($obj);
print_report($obj) if $obj;
PrintBottom();

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

sub print_study {
  my $stud_name = shift;
  my $study = $DB->fetch(Map_Study => $stud_name);
  if ( my $reference = $study->Cited_in) {
    my $title     = $reference->Title;
    my $author    = $reference->Author;
    print h2("$title ($author)");
  } else {
    print p($study->Remarks);
  }
}

sub print_prompt {
  my @studies = sort $DB->fetch(-query => 'find Map_study Linkage_Group');
  unshift @studies,'--';
  my $study = param('study');
  print start_table();

  print start_form(-name=>'form1');
  print hidden('class' => 'Map');
  print TR(
	   th({-align=>'RIGHT'},'Mapping Study'),
	   td({-colspan=>2},
	      popup_menu(-name     => 'study',
			 -value    => \@studies,
			 -onChange => 'document.form1.submit()')),
	   td(submit('Select'))
	     );
  print end_form;

  if ($study) {
    my ($study_obj) = grep { $_ eq $study } @studies;
    my @maps    = sort $study_obj->Linkage_Group;
    unshift @maps,'--';

    print start_form(-name=>'form2');
    print hidden(-name => 'study',
		 -value => $study);

    print hidden(-name  => 'class',
		 -value => 'Map');
    print TR(
	     th({-align=>'RIGHT'},'Map'),
	     td(popup_menu(-name  => 'name',
			   -value => \@maps,
			   -onChange => 'document.form2.submit()'
			  ),
		checkbox(-name=>'Marker details',-checked=>0),
	       ),
	     param('name') ? td(submit('Download Map')) : '',
	     td(submit('Select')),
	    );
    print end_form();
  }
  print end_table;
  print p('Check',i('Marker details'),'and press','Select',
	  'to see molecular marker information.',
	  'Press',i('Download Map'),'to download a spreadsheet-compatible copy.');
}

sub print_report {
  my $map = shift;
  my $details = param('Marker details');
  my $marker_info = marker_info($map) if $details;

  my @rows;
  my @data = $DB->aql(sprintf(AQL_ALL,$map,$map));
  for my $row (@data) {
    my ($link,$locus,$position) = @$row;
    my($marker,$type,$forward,$reverse,$size,$polymorphism,$trait,$remarks)
      = @{$marker_info->{$locus}}{qw(marker type forward reverse size polymorphism trait remarks)};

    my   @a =  (ObjectLink($link),ObjectLink($locus),$position);
    push @a,   (ObjectLink($marker),$type,$forward,$reverse,$size,$polymorphism,$trait,i($remarks)) if $details;
    push @rows,td({-align=>'RIGHT'},[map {length($_)>0 ? $_ : NBS} @a]);
  }
  print table({-border=>1},
	      TR(th(['Link Group','Locus','Position (cM)',$details ? ('Marker','Type','Primer1','Primer2',
								      'Size','Polymorphism','Trait','Remarks')
                                                                   :  () ])),
	      TR(\@rows),
	     );
}

sub marker_info {
  my $map = shift;
  my %marker_info;
  my @markers = $DB->aql(sprintf(AQL_MARKERS,$map));
  foreach (@markers) {
    my($locus,$marker,$type,$forward,$reverse,$size,$motif,$polymorphism,$trait,$remarks,$full_name,$aflp_primer) = @$_;
    $size =~ s/\s+bp//;
    $marker_info{$locus}{marker}  ||= $marker;
    $marker_info{$locus}{type}    ||= $type;
    $marker_info{$locus}{forward} ||= $forward || $aflp_primer;
    $marker_info{$locus}{reverse} ||= $reverse || $aflp_primer;
    $marker_info{$locus}{size}    ||= $size ? qq($size $motif) : '';
    $marker_info{$locus}{polymorphism}{$polymorphism}++;
    $marker_info{$locus}{trait}   ||= $trait;
    $marker_info{$locus}{remarks} ||= ($full_name||$remarks) ?  "$full_name $remarks " : '';
  }
  foreach (keys %marker_info) {
    next unless $marker_info{$_}{polymorphism};
    $marker_info{$_}{polymorphism} = join ', ',grep {$_} keys %{$marker_info{$_}{polymorphism}};
  }
  \%marker_info;
}

sub download {
  my $map = shift;
  my $details     = param('Marker details');
  my $marker_info = marker_info($map) if $details;

  my $query = sprintf(AQL_ALL,$map,$map);
  print header(-type => 'application/binary-octet-stream',
	       -attachment => "$map.txt",
	      );

  for my $row ($DB->aql($query)) {
    push @$row,@{$marker_info->{$row->[1]}}{qw(marker type forward reverse size polymorphism trait remarks)}
      if $details;
    print join "\t",@$row,"\n";
  }
}
