#!/usr/local/bin/perl5.6.1
#
# Author John Attwood (ja1)
#
package main;

#
# first set up @INC so that we can find our modules and sql_libs
#
use GT::FindBin;

use lib "$Bin/../../..";

package GT::Project::Anitrack::PedInfo;
use strict;
use warnings;
use Carp;

#
# This is the Model for the Pedigree display
#

use SqlEngine2;
my $se2 = new SqlEngine2;

my ($dbh, $info);

sub getInfo {
    my ($login, $mouse) = @_;


    #
    # populate the model from the database#
    #
    $info = {};        # data structure for the model
    my %idEs = ();     # keys will be idEs of mice encountered, values their generations within the pedigree
    my %parentOf = (); # holds lists of offspring for each mated mouse
    $dbh = SqlEngine2::getDbh($login);
    #
    # translate our name into a mouse id_entity and add it to our hash of individuals
    #
    my $targetIdE = $se2->getRow('GT/Project/Anitrack/pedInfo::getMouseIdEFromName', [$mouse], $dbh)
	or croak "$mouse not found\n";
    $idEs{$targetIdE} = 3; # target will be 3rd generation in display
    #
    # get target's parent(s), adding them to our collections as we go
    #
    my $res = $se2->getAll('GT/Project/Anitrack/pedInfo::getParentIdE', [$targetIdE], $dbh);
    if ($res->[0]) {
	foreach my $p (@{$res}) {
	    my ($parent) = @{$p};
	    $idEs{$parent} = 2; # parents will be 2nd generation in display
	    $parentOf{$targetIdE} ||= [];
	    push @{$parentOf{$targetIdE}}, $parent;
	    #
	    # get target's grandparent(s)
	    #
	    my $res2 = $se2->getAll('GT/Project/Anitrack/pedInfo::getParentIdE', [$parent], $dbh);
	    if ($res2->[0]) {
		foreach my $gp (@{$res2}) {
		    my ($grandparent) = @{$gp};
		    $idEs{$grandparent} = 1; # grandparents will be 1st generation in display
		    $parentOf{$parent} ||= [];
		    push @{$parentOf{$parent}}, $grandparent;
		}
	    }
	}
    }
    #
    # get target's mate(s) and offspring of each mating, adding them to our collections
    #
    $res = $se2->getAll('GT/Project/Anitrack/pedInfo::getMateIdE', [$targetIdE], $dbh);
    if ($res->[0]) {
	foreach my $m (@{$res}) {
	    my ($mate, $matingCard) = @{$m};
	    $idEs{$mate} = 3; # mate will also be 3rd generation in display
	    #
	    # get offspring of this mating
	    #
	    my $res2 = $se2->getAll('GT/Project/Anitrack/pedInfo::getOffspringIdE', [$matingCard], $dbh);
	    if ($res2->[0]) {
		foreach my $p (@{$res2}) {
		    my ($pup) = @{$p};
		    $idEs{$pup} = 4; # offspring will be 4th generation in display
		    push @{$parentOf{$pup}}, $mate; # so that we can tell the mating it belongs to
		}
	    }
	}
    }
    #
    # now, find out what we need to know about all the mice in $idEs hash
    #
    foreach my $idE (keys %idEs) {
	my $name = $se2->getRow('GT/Project/Anitrack/pedInfo::getMouseNameFromIdE', [$idE], $dbh);
	my $sex = $se2->getRow('GT/Project/Anitrack/pedInfo::getSexFromIdE', [$idE], $dbh) || 'N';
	my $dead = $se2->getRow('GT/Project/Anitrack/pedInfo::isDeadFromIdE', [$idE], $dbh) || 0;
      	$res = $se2->getAll('GT/Project/Anitrack/pedInfo::getGenosFromIdE', [$idE], $dbh);
	my $genotype;
	foreach (@{$res}) {
	    my ($loc, $geno, $isCurr, $date) = @{$_};
	    $genotype->{$loc} =  $geno;
	}
	#
	# and enter this individual's details in the model
	#
	$info->{$idE} = {name => $name,
			 generation => $idEs{$idE},
			 sex => $sex,
			 dead => $dead,
			 genos => $genotype,
			 parents => $parentOf{$idE},
		     };

    }
    #
    # pass back the populated model
    #
    return $info;
}

package GT::Project::Anitrack::PedigreeBrowser;;
use strict;
use warnings;

use Tk;
use Tk::ErrorDialog;
use Tk::NoteBook;
#
# This is the View/Controller for the Pedigree Display
#
use constant HORIZ_SPACING => 60;   # offspring will be offset by this amount (canvas coords)
use constant DISPLACEMENT  => 80;   # target's parents will be offset by this amount (canvas coords)
use constant PAGEWIDTH     => 1100; # width of canvas to print per A4 landscape page
use constant RIGHTMOST_SEX => 'F';  # this sex will be drawn on the right side of a mating
use constant NO_FETCH      => 1;    # boolean flag to skip updating the model/tabs when redrawing

my ($mw, $mouseName, $canvas, $login, $model, $backButton, @stack, $probandPos, $nb, @tabs, @mates);

sub run {
    my ($name, $myLogin, $main) = @_;

    #
    # set everything up and draw a pedigree if we have a named target individual
    #
    $login = $myLogin;       # WrapDBI connect string
    $mouseName = $name;      # target individual
    $mw = $main;             # parent Frame 
    #
    # render our widgets
    #
    _initGraphics();
    #
    # try to draw a pedigree, suppressing errors as there's nowhere yet to report them
    #
    eval { _draw() if $mouseName };
}

sub _initGraphics {
    #
    # frame to hold the input widgets
    #
    my $topFrame = $mw->Frame()->pack(-side => 'top',
				      -fill => 'x',
				      -expand => 1);
    $topFrame->Label(-text => 'Target mouse: ')->pack(-side => 'left');
    $topFrame->Entry(-textvariable => \$mouseName,
		     -background => 'white',)->pack(-side => 'left');
    $topFrame->Button(-text => 'Draw',
		      -command => \&_draw)->pack(-side => 'left');
    $backButton = $topFrame->Button(-text => 'Back',
				 -state => 'disabled',
				 -command => \&_back)->pack(-side => 'left');
    #
    # tabs to select the mating(s) for the target animal
    #
    $nb = $mw->NoteBook()->pack(-side => 'top',
				-fill => 'x',
				-expand => 1);
    #
    # carte blanche for drawing routines
    #
    $canvas = $mw->Scrolled('Canvas', 
			    -width => 1000,
			    -scrollbars => 'osoe',
			    -background => 'white')->pack(-side => 'top',
							  -fill => 'both',
							  -expand => 1);
    #
    # frame to hold the control widgets
    #
    my $btnFrame = $mw->Frame()->pack(-side => 'bottom',
				      -fill => 'x',
				      -expand => 1);
    $btnFrame->Button(-text => 'Exit', 
		      -command => sub{ exit })->pack(-side => 'right');
    $btnFrame->Button(-text => 'Print',
		      -command => \&hardCopy)->pack(-side => 'left');
}

sub hardCopy {
    #
    # Simplistic way of generating hardcopy of such an awkardly-shaped rectangle.
    #
    # get the current bounding box
    #
    my ($x1, $y1, $x2, $y2) = $canvas->bbox('all');
    #
    # now step through the canvas, PAGEWIDTH units at a time,
    # producing postscript for each horizontal section.
    # saving the output as targetMouseName-section.ps in the cwd.
    #
    my $i = 1;
    my $left = $x1;
    while ($left < $x2) {
	$canvas->postscript(-file => "./$mouseName-$i.ps",
			    -rotate => 1,
			    -x => $left,
			    -width => PAGEWIDTH,
			    );
	$i++;
	$left += PAGEWIDTH;
    }
}

sub _back {
    #
    # throw away the name of the current target
    #
    pop @stack;
    #
    # if there's anything left to go back to, then redisplay the previous target
    #
    if (@stack) {
	$mouseName = pop @stack;
	$backButton->configure(-state => 'disabled') unless @stack; 
	_draw();
    }
}

sub _draw {
    my ($noFetch) = @_;

    #
    # Display stopwatch cursor and stop responding to user
    #
    $mw->Busy(-recurse => 1);
    eval {
	unless ($noFetch) {
	    #
	    # populate the model from the database, starting with the target mouse
	    #
	    $model = GT::Project::Anitrack::PedInfo::getInfo($login, $mouseName);
	    #
	    # save the previous name so we can return to it and activate the Back button
	    #
	    push @stack, $mouseName;
	    $backButton->configure(-state => 'normal') if @stack > 1;
	}
	#
	# clear the canvas
	#
	$canvas->delete('all');
	my @parents = grep {$_->{generation} == 3} values %{$model};
	unless ($noFetch) {
	    #
	    # clear the matings tab(s)
	    foreach my $tab (@tabs) {
		$nb->delete($tab);
	    }
	    #
	    # configure tabs for the matings in the model
	    #
	    @tabs = ();
	    foreach my $p (@parents) {
		next if $p->{name} eq $mouseName;
		$nb->add($p->{name}, 
			 -label => $mouseName . " x " . $p->{name},
			 );
		push @tabs, $p->{name}
	    }
	    if (@tabs) { 
		$nb->raise($tabs[0]);
		foreach my $tab (@tabs) {
		    $nb->pageconfigure($tab, -raisecmd => sub { _draw(NO_FETCH) });
		}
	    }
	}
	#
	# start drawing at the bottom so that we know how wide the pedigree will be
	#
	my @offspring = grep {$_->{generation} == 4} values %{$model};
	my $width = _drawOffspring(@offspring);
	#
	# draw the higher levels
	#
	_drawParents($width, @parents);
	my @grandparents = grep {$_->{generation} == 2} values %{$model};
	_drawGrandParents($width, @grandparents);
	_drawGreatGrandparents($width, @grandparents);
	#
	# set up our scrollbars
	#
	$canvas->configure(-scrollregion => [$canvas->bbox('all')]);
	$mw->idletasks();
	#
	# and move the target mating into view
	#
	my ($left, $right) = $canvas->xview(); # print "$left, $right\n";
	$canvas->xviewMoveto(($left + (1.0 - $right)) / 2);
    };
    my $msg = $@;
    #
    # always call Unbusy, even after an error, to avoid freezing the GUI controls
    #
    $mw->Unbusy();
    if ($msg) {
	#
	# print and rethrow any error
	#
	warn $msg;
	die $msg ;
    }
}

sub _drawGreatGrandparents {
    my ($width, @grandparents) = @_;

    return unless @grandparents;
    #
    # calculate our mid-point and fix height for generation 1
    #
    my $centre = $width / 2 + DISPLACEMENT * $probandPos;
    my $y = 0;
    if (_siblings(@grandparents)) {
	#
	# special case where grandparents are siblings
	#
	my @ggp = @{$grandparents[0]->{parents}};
	foreach my $m (@grandparents) {
	    my $ppos = $m->{sex} eq 'M' ? DISPLACEMENT : -(DISPLACEMENT);
	    my $pcentre = $centre + $ppos;
	    $canvas->createLine($pcentre + 10, $y + 50, $pcentre + 10, $y + 70);
	    $canvas->createLine($pcentre + 10, $y + 50, $centre, $y + 50);
	}
	$canvas->createLine($centre + 10, $y + 10, $centre + 10, $y + 50);
	$canvas->createLine($centre - DISPLACEMENT + 20, $y + 10, $centre + DISPLACEMENT, $y + 10);
	foreach my $ggp (@ggp) {
	    my $m = $model->{$ggp};
	    my $pos = $m->{sex} eq RIGHTMOST_SEX ? DISPLACEMENT : -(DISPLACEMENT);
	    _drawMouse($m, $centre + $pos, $y);
	
	}
    } else {
	#
	# greatgrandparents must be drawn above the correct grandparent
	#
	foreach my $m (@grandparents) {
	    #
	    # calculate local mid-point
	    #
	    my $ppos = $m->{sex} eq 'M' ? DISPLACEMENT : -(DISPLACEMENT);
	    my $pcentre = $centre + $ppos;
	    foreach my $ggp (@{$m->{parents} || []}) {
		#
		# and draw this grandparent's parents
		#
		my $m = $model->{$ggp};
		my $pos = $m->{sex} eq RIGHTMOST_SEX ? DISPLACEMENT / 2 : -(DISPLACEMENT) / 2;
		_drawMouse($m, $pcentre + $pos, $y);
	    }
	    last unless @{$m->{parents} || []};
	    $canvas->createLine($pcentre - DISPLACEMENT / 2 + 20, $y + 10, $pcentre + DISPLACEMENT / 2, $y + 10);
	    $canvas->createLine($pcentre + 10, $y + 10, $pcentre + 10, $y + 70);
	}
    }
}

sub _siblings {
    my (@pair) = @_;

    #
    # work out whether two individuals share common parents.
    #
    return 0 if @pair < 2; # can't be siblings if less than 2 mice!
    return 0 unless $pair[0]->{parents} and $pair[1]->{parents}; # can't be siblings unless we know their parents
    #
    # retrieve and sort both sets of parents
    #
    my @p0 = sort @{$pair[0]->{parents}};
    my @p1 = sort @{$pair[1]->{parents}};
    return 0 unless @p0 == 2 and @p1 == 2; # can't be siblings unless we know all their parents
    #
    # siblings only if both their parents are the same
    #
    return "@p0" eq "@p1";
}

sub _drawGrandParents {
    my ($width, @grandparents) = @_;

    return unless @grandparents;
    #
    # calculate local midpoint and set height for generation 2
    #
    my $centre = $width / 2 + DISPLACEMENT * $probandPos;
    my $y = 70;
    foreach my $m (@grandparents) {
	#
	# draw this grandparent
	#
	my $pos = $m->{sex} eq RIGHTMOST_SEX ? DISPLACEMENT : -(DISPLACEMENT);
	_drawMouse($m, $centre + $pos, $y);
    }
    $canvas->createLine($centre - DISPLACEMENT + 20, $y + 10, $centre + DISPLACEMENT, $y + 10);
    $canvas->createLine($centre + 10, $y + 10, $centre + 10, $y + 80);
}
sub _drawParents {
    my ($width, @parents) = @_;

    #
    # calculate local midpoint and set height for generation 3
    my $y = 150;
    my $centre = $width / 2;

    foreach my $m (@parents) {
	my $pos = $m->{sex} eq RIGHTMOST_SEX ? DISPLACEMENT : -(DISPLACEMENT);
	if ($m->{name} eq $mouseName) {
	    #
	    # remember which side our target mouse was drawn on
	    #
	    $probandPos = $m->{sex} eq RIGHTMOST_SEX ? 1 : -1;
	} elsif ($m->{name} ne $nb->raised()) {
	    #
	    # skip mates not on the current notebook tab
	    #
	    next;
	}
	#
	# draw the parent
	#
	_drawMouse($m, $centre + $pos, $y);
    }
    return unless @parents >= 2;
    $canvas->createLine($centre - DISPLACEMENT + 20, $y + 10, $centre + DISPLACEMENT, $y + 10);
    $canvas->createLine($width / 2 + 10, $y + 10, $width / 2 + 10, $y + 80);
}

sub _drawOffspring {
    my @offspring = @_;

    return 50 unless @offspring;
    #
    # set the height for generation 4 and start from the left edge of the canvas
    #
    my $y = 250;
    my $offset = 0;
    my $mate = $nb->raised();
    #
    # sort the offspring by their names and draw them on the pedigree
    #
    foreach my $m (sort { _sensibly($a->{name}, $b->{name})} @offspring) {
	#
	# ignore sibs unless they belong to mating on the current notebook tab
	#
	next unless $info->{$m->{parents}[0]}{name} eq $mate;
	#
	# move 1 step to the right and draw the mouse
	#
	$offset += HORIZ_SPACING;
	_drawMouse($m, $offset, $y);
    }
    $canvas->createLine(HORIZ_SPACING  + 10, $y - 20, $offset + 10, $y-20);
    #
    # pass back the width of the row of offspring
    #
    return $offset;
}

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

    #
    # Get the details from the model
    #
    my $sex = $info->{sex};
    my ($geno) = values %{$info->{genos}}; # ignore all but first locus
    my $parents = $info->{parents};
    my $name = $info->{name};
    $geno ||= '';
    #
    # in the absence of genotype/phenotype mappings, fill symbol with black if genotype contains
    # any non-wildtype allele (ie if the genotype contains any characters except '+' and '/').
    #
    my $fill = ($geno =~ /[^+\/]/) ? 'black': 'white';
    #
    # Draw symbols based on the sex, filling them with black if necessary
    #
    if ($sex eq 'M') {
	$canvas->createRectangle($x, $y, $x + 20, $y + 20, 
				 -fill => $fill,
				 -tags => $name);
    } elsif ($sex eq 'F') {
	$canvas->createArc($x, $y, $x + 20, $y + 20, 
			   -extent => 359, 
			   -style => 'chord', 
			   -fill => $fill,
			   -tags => $name);
    } else {
	$canvas->createPolygon($x + 10, $y, 
			       $x + 20, $y + 10,
			       $x + 10, $y + 20,
			       $x,      $y + 10,
			       -fill => $fill,
			       -outline => 'black',
			       -tags => $name);

    }
    #
    # Strike through dead individuals
    #
    if ($info->{dead}) {
	$canvas->createLine($x + 23, $y - 3,
			    $x -  3, $y + 23);
    }
    #
    # Put a '?' in the middle of the symbol if the genotype is unknown
    #
    if ($geno eq '') {
	$canvas->createText($x + 10, $y + 10,
			    -text => '?');
    }
    #
    # Bind double-clicks to the _draw() subroutine
    #
    $canvas->bind($name, '<Double-1>', sub { $mouseName = $name; _draw()});
    #
    # Print the name under the symbol, in red if it's the target animal
    #
    $canvas->createText($x, $y + 30, 
			-text => $name,
			-fill => $name eq $mouseName ? 'red' : 'black');
    #
    # print the genotype under the name
    #
    $canvas->createText($x, $y + 40,
			-text => $geno);
    return unless $info->{generation} == 4; # or $info->{parents};
    #
    # draw a vertical line above symbol if this is an offspring of the target or 
    # has parent(s) of its own
    $canvas->createLine($x + 10, $y, $x + 10, $y - 20);
}

# This subroutine splits off the left-hand component of both symbols and
# compares them (numerically if they are both composed of digits, lexically
# otherwise). If they are different, it returns with a value indicating which
# comes first, otherwise it reinvokes itself recursively with the remainder
# of the two symbols until either a difference is found, or else one or both
# of the symbols has been exhausted. Note that this will only work if all
# symbols to be sorted are guaranteed to start with the same thing (digit 
# or letter).

sub _sensibly {
        my ($aa, $bb) = @_;
        my ($a_lhs, $b_lhs);

        return $aa cmp $bb if $aa eq "" or $bb eq "";
        $aa =~ s/^(\D+|\d+)//;
        $a_lhs = $1;
        $bb =~ s/^(\D+|\d+)//;
        $b_lhs = $1;
        if ($a_lhs =~ /^[0-9]/ and $b_lhs =~ /^[0-9]/) {
                if ($a_lhs == $b_lhs) {
                        return _sensibly($aa, $bb);
                } else {
                        return $a_lhs <=> $b_lhs;
               }
        } else {
                if ($a_lhs eq $b_lhs) {
                        return _sensibly($aa, $bb);
                } else {
                        return $a_lhs cmp $b_lhs;
                }
        }
}

package main;
use strict;
use warnings;
use Tk;

#
# Wrapper to allow gui to be invoked from command line
#
# use constant LOGIN => 'anitrack_mirror';
use constant LOGIN => 'anitrack';

my $mouse = shift ||  die "Usage: $0 <mouse_name>\n";

eval {
    #
    # create a window and draw a pedigree inside it
    #
    my $mw = MainWindow->new();
    $mw->title('Anitrack Pedigree Browser');
    GT::Project::Anitrack::PedigreeBrowser::run($mouse, LOGIN, $mw);
    #
    # interact with users until they get bored and quite
    #
    MainLoop();
    
};
#
# print a diagnostic message if an error occurred before the GUI could display it
#
print $@ if $@;
