package ATR::Report::Dotty;
use base 'ATR::Report';

use strict;
use warnings;
use Carp;


=head1 NAME

ATR::Report::Dotty - Dotty generator subclass for ATR::Report

=cut

# $Id: Dotty.pm,v 1.1 2005/01/15 18:50:58 mca Exp $

#----------------------------------------------------------------------------

sub _init {
    my ($self, @args) = @_;
    my @left = $self->SUPER::_init(@args);

    $self->{lookup} = {};
    $self->{seen_node} = {};

    $self->print("/* Generated by AniTrack demo */\n",
		 "digraph G {\n",
		 " node [ shape=rectangle ]\n");

    return @left;
}

sub finish {
    my $self = shift;
    $self->print("}\n");
}


sub addMouse {
    my ($self, $mouse) = @_;
    $self->_make_node($mouse);
}

sub addMatingLitter {
    my ($self, $mating, $litter) = @_;
    $self->_make_node($litter);
    $self->_make_edge($mating->getMatingName, "matingpair", $litter->getLitterName, "litter");
}

sub addMatingPair {
    my ($self, $pair) = @_;
    $self->_make_node($pair->getMatingName, "matingpair");
}

sub addMatingParent {
    my ($self, $mating, $parent) = @_;
    $self->_make_edge($parent->getMouseName, "mouse", $mating->getMatingName, "matingpair");
}

sub addLitterMouse {
    my ($self, $litter, $pup) = @_;
    $self->_make_edge($litter->getLitterName, "litter", $pup->getMouseName, "mouse");
}


sub _make_edge {
    my $self = shift;
    my ($n1, $y1, $n2, $y2) = @_;
    my ($t1, $t2) = ($self->_make_name($n1, $y1),
		     $self->_make_name($n2, $y2));
    my $args = 'color=black';
    $self->print(" $t1 -> $t2 \[ $args ];\n");
}

sub _make_node {
    my $self = shift;
    my ($name, $type) = @_;

    my $obj;
    if (ref($name)) {
	$obj = $name;
	$type = { 'ATR::MicePE::Mouse' => 'mouse',
		  'ATR::MicePE::MatingPair' => 'matingpair',
		  'ATR::MicePE::LitterGroup' => 'litter',
		}->{ref($obj)};
	my $method = { mouse => 'getMouseName',
		       matingpair => 'getMatingName',
		       litter => 'getLitterName',
		     }->{$type};
	$name = $obj->$method;
    }

    my $token = $self->_make_name($name, $type);

    return if $self->{seen_node}->{$token};
    $self->{seen_node}->{$token} ++;

    my $args = { mouse => 'color=red',
		 matingpair => 'color=green',
		 litter => 'color=blue',
	       }->{$type};
    confess "Unknown node type '$type' for '$name'" unless $args;

    my $lbl = $name;
    if ($type eq 'mouse' && $obj) {
	my $geno = $obj->getGenotype;
	$lbl .= "\\n$geno" if defined $geno;
    }

    $self->print(" $token \[ $args, label=\"$lbl\" ];\n");
}

sub _make_name {
    my $self = shift;
    my ($name, $type) = @_;
    my $key = $name."::".$type;
    return $self->{lookup}->{$key} if exists $self->{lookup}->{$key};

    my $token = $name;
    $token = "num$token" if $token =~ /^\d+/;
    $token =~ s/[^a-z0-9_]/_/gi;
    my $suff = '';
    my %rev = reverse %{ $self->{lookup} };
    while (exists $rev{$token.$suff}) {
	if ($suff) {
	    $suff++;
	} else {
	    $suff = 'aa';
	}
    }
    return $self->{lookup}->{$key} = $token.$suff;
}


1;
