#!/usr/bin/perl

=head1 NAME

dotcat - combine several doxygen dot files into a single dot file

=head1 SYNOPSIS

dotcat in1.dot in2.dot in3.dot ...

=head1 DESCRIPTION

dotcat combines all the dot files given as arguments into a single dot file,
which is printed to stdout.

Pass the argument --disable-pruning if you don't want duplicate nodes &
edges pruned.

The dot command I like to use for Doxygen is:
 dot -Tpng -Gconcentrate="true" -Grankdir="LR" -Esametail=1 -Esamehead=2

Possibly followed by:
 unflatten -c 3 -l 3

=head1 VERSION

0.4

=head1 AUTHOR

Mark Ivey <zovirl@zovirl.com>

=head1 LICENSE

Copyright (c) 2004 Mark Ivey.  All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 DEVELOPER DOCUMENTATION

The rest of the documentation is not needed for users of the program, 
but might be of interest for developers.

=cut

use warnings; # can't use -w because of Graph::Reader::Dot
use strict;
use English;

my $VERSION = 0.4;
my $DEBUG = 0;

################################################################################
package Node;
use warnings;
use strict;
use English;

=head2 Class Node

represents a single node

=head3 Members

=over 4

=item name

=item name(new_name)

Name of the node

=item label

=item label(new_label)

Label of the node

=item attributes

=item attributes(new_attributes)

hash of attributes for this node

=back

=cut

use Class::MethodMaker
    new_with_init => 'new',
    new_hash_init => '_hash_init',
    get_set=> 'name',
    get_set=> 'label',
    get_set=> 'attributes',
    ;

use constant DEFAULTS => (  name => 'Unnamed',
                            label => 'Unlabeled'
                        );

sub init
{
    my $self = shift;
    my %args = ( DEFAULTS, @ARG );      # @ARG overrides DEFAULTS
    
    $self->_hash_init ( %args );
}

################################################################################
package Edge;
use warnings;
use strict;
use English;

=head2 Class Edge

represents an edge between two nodes

=head3 Members

=over 4

=item node1

=item node1(new_node)

First (head) node of edge

=item node2

=item node2(new_node)

Second (tail) node of edge

=item label

=item label(new_label)

Label of the edge

=item attributes

hash of attributes for this edge

=back

=cut

use Class::MethodMaker
    new_with_init => 'new',
    new_hash_init => '_hash_init',
    get_set=> 'node1',
    get_set=> 'node2',
    get_set=> 'label',
    get_set=> 'attributes',
    ;

use constant DEFAULTS => (  node1 => 'Unnamed_Node1',
                            node2 => 'Unnamed_Node2',
                            label => 'Unlabeled'
                        );

sub init
{
    my $self = shift;
    my %args = ( DEFAULTS, @ARG );      # @ARG overrides DEFAULTS
    
    $self->_hash_init ( %args );
}

################################################################################
package DotGraph;
use warnings;
use strict;
use English;

=head2 Class DotGraph

A graph which can be populated with the contents of various dot graphs.  
DotGraph also provides several different ways to deal with duplicate nodes.

=head3 Members

=over 4

=item _vertices 

array of vertices

=item _edges 

array of edges (which reference vertex indices instead of vertex names.  They
are resolved back to vertex names during get_contents())

=back 

=cut

use Class::MethodMaker
    new_with_init => 'new',
    new_hash_init => '_hash_init',
    get_set=> '_vertices',
    get_set=> '_edges',
    ;

use constant DEFAULTS => (  _vertices => [],
                            _edges => [],
                        );

=head3 Methods

=over 4

=cut

sub init
{
    my $self = shift;
    my %args = ( DEFAULTS, @ARG );      # @ARG overrides DEFAULTS
    
    $self->_hash_init ( %args );
}

=item shift2()

shifts 2 items off an array (from perl cookbook)

=cut

sub shift2 (\@)
{
    return splice( @{$_[0]}, 0, 2 );
}

=item add_dot_graph()

Add the contents of a dot graph

=cut

sub add_dot_graph()
{
    my $self = shift;
    my $graph = shift;
    my %names;  # name->index records for the nodes in this graph
    
    print STDERR "----------Adding graph----------\n" if ($DEBUG >= 1);
    
    # copy verticies
    foreach my $name ($graph->vertices())
    {
        my $label = $graph->get_attribute("label", $name);
        
        # discard nodes with the same name
        if (exists $names{$name})
        {
            warn "Warning: Duplicate node found. Name $name, Label $label.  Discarding\n";
            next;
        }
        
        push @{$self->_vertices}, Node->new(name=>$name, 
                                            label=>$label, 
                                            attributes=>{$graph->get_attributes($name)},
                                        );
        $names{$name} = scalar @{$self->_vertices} - 1; # get index of new node
        
        print STDERR "Node #$names{$name} Name[$name] Label[$label]\n" if ($DEBUG >= 2);
    }

    # copy edges
    my @E = $graph->edges();
    print STDERR "Edges: [@E]\n" if ($DEBUG >=2);
    while ( my ($u, $v) = shift2 @E )
    {
        my ($i, $j) = ($names{$u}, $names{$v}); # node indices
        
        # discard undefined edges
        if (not defined $i or not defined $j)
        {
            warn "Warning: Edge ($u, $v) refers to non-existent node.  Discarding\n";
            next;
        }
        
        my $label = $graph->get_attribute("label", $u, $v);
        push @{$self->_edges}, Edge->new(   node1=>$i,
                                            node2=>$j,
                                            label=>$label,
                                            attributes=>{$graph->get_attributes($u, $v)},
                                        );
        my $index = scalar @{$self->_edges} - 1; # get index of new edge
        print STDERR "Edge #$index Nodes[$i,$j]\n" if ($DEBUG >= 2);
    }
}    

=item rank_node_attributes()

Given a ref. to a hash of node attributes, return 
a score saying how much we like it.  This
can then be used to compare two sets of attributes.  Higher numbers mean
we like the set better than low numbers.

=cut

sub rank_node_attributes
{
    my $self = shift;
    my $a = shift;

    return 4 if ($a->{"color"} eq "black" and 
                (not exists $a->{"style"} or $a->{"style"} ne "filled"));
    return 3 if ($a->{"color"} eq "grey75");
    return 2 if ($a->{"color"} eq "red");
    return 1 if ($a->{"style"} eq "filled");    
}

=item prune_nodes_by_label()

Prunes nodes which have the same label

=cut

sub prune_nodes_by_label()
{
    my $self = shift;
    
    print STDERR "----------Pruning nodes by label----------\n" if ($DEBUG >= 1);

    my %labels;             # label->index hash of labels we have seen
    my %replacement_map;    # old_index->new_index hash of duplicate nodes we have seen
    
    # find and remove duplicate nodes
    my $index = -1;
    foreach my $v (@{$self->_vertices})
    {
        $index++;
        next unless defined $v;
        
        my $label = $v->label;
        if (exists $labels{$label})
        {
            my $previous_index = $labels{$label};
            my $previous_v = $self->_vertices->[$previous_index];
            
            print STDERR "Node #$index replaced by node #previous_index\n" if ($DEBUG >=2);
            
            # check to see if we prefer the new node's attributes
            if ($self->rank_node_attributes($v->attributes) > 
                $self->rank_node_attributes($previous_v->attributes))
            {
                $previous_v->attributes( $v->attributes );
            }
            
            $replacement_map{$index} = $previous_index;
            delete @{$self->_vertices}[$index];
        }
        else
        {
            $labels{$label} = $index;
        }
    }
        
    # fix edges which point to removed nodes
    foreach my $e (@{$self->_edges})
    {
        next unless defined $e;
        my ($i, $j) = ($e->node1, $e->node2);
        
        $e->node1($replacement_map{$i}) if (exists $replacement_map{$i});
        $e->node2($replacement_map{$j}) if (exists $replacement_map{$j});
    }
}

=item prune_edges()

prunes duplicate edges 
(2 edges for which a->node1 == b->node1 && a->node2 == b->node2)

=cut

sub prune_edges
{
    my $self = shift;

    print STDERR "----------Pruning duplicate edges----------\n" if ($DEBUG >= 1);

    my %edges;
    
    my $index = -1;
    foreach my $e (@{$self->_edges})
    {
        $index++;
        next unless defined $e;
        my ($i, $j) = ($e->node1, $e->node2);
        my $key = "$i:$j";
        
        if (exists $edges{$key})
        {
            # FIXME: better choice of which to delete would be nice
            print STDERR "Edge #$index replaced by edge #$edges{$key} Nodes[$i,$j]\n" if ($DEBUG >=2);
            delete @{$self->_edges}[$index];
        }
        else
        {
            $edges{$key} = $index;
        }
    }
}

=item resolve_name_conflicts()

renames nodes with duplicate names

=cut

sub resolve_name_conflicts
{
    my $self = shift;
    my %all_names;

    print STDERR "----------Resolving name conflicts----------\n" if ($DEBUG >= 1);

    my $index = -1;
    foreach my $v (@{$self->_vertices})
    {
        $index++;
        next if not defined $v;
        
        my $name = $v->name;
        
        # look for a name which isn't already in use
        $name = $name . "_" while (defined $all_names{$name});
        
        if ($name ne $v->name)
        {
            # our original name was in use
            print STDERR "Node #$index Name[".$v->name."]-->[$name]\n" if ($DEBUG >=2);
            $v->name($name);
        }
        $all_names{$name} = 1;
    }
}

=item get_contents()

Returns the contents of the graph as a Graph::Directed object.  Calls
resolve_name_conflicts() to resolve any name conflicts before returning.

=cut

sub get_contents
{
    my $self = shift;
    my $graph_out = Graph::Directed->new();
        
    # have to fix duplicate names before getting contents
    $self->resolve_name_conflicts(); 

    print STDERR "----------Returning Contents----------\n" if ($DEBUG >= 1);

    my $index = -1;
    foreach my $v (@{ $self->_vertices })
    {
        $index++;
        next if not defined $v;
        
        print STDERR "Node #$index ". $v->name . ": " if ($DEBUG >= 2);
        $graph_out->add_vertex($v->name);
        
        # copy this node's attributes
        while ( my ($attr, $value) = each %{ $v->attributes() } )
        {
            print STDERR "$attr=$value " if ($DEBUG >= 2);
            $graph_out->set_attribute($attr, $v->name, $value);
        }
        print STDERR "\n" if ($DEBUG >= 2);
    }
    
    $index = -1;
    foreach my $e (@{$self->_edges})
    {
        $index++;
        next if not defined $e;
        
        # look up node names
        my ($i, $j) = ( $e->node1, $e->node2);
        my ($u, $v) = ( $self->_vertices->[$i]->{name}, 
                        $self->_vertices->[$j]->{name});
        
        print STDERR "Edge #$index Nodes[$i,$j] " if ($DEBUG >= 2);        
        $graph_out->add_edge($u, $v);
        
        # copy this edges's attributes
        while ( my ($attr, $value) = each %{ $e->attributes() } )
        {
            print STDERR "$attr=$value " if ($DEBUG >= 2);
            $graph_out->set_attribute($attr, $u, $v, $value);
        }
        print STDERR "\n" if ($DEBUG >= 2);
    }    
    
    return $graph_out;
}

=back

=cut

################################################################################
package main;

use Graph; 
use Graph::Reader::Dot; 
use Graph::Writer::Dot; 

my $graph = DotGraph->new();

my $reader = Graph::Reader::Dot->new(); 
my $writer = Graph::Writer::Dot->new(); 

my $pruning = 1;    # do we prune duplicate nodes & edges or not?

# read input graphs & add them to $DotGraph
foreach my $file (@ARGV)
{
    if ($file eq "--disable-pruning")
    {
        $pruning = 0;
        next;
    }
    
    $graph->add_dot_graph( $reader->read_graph($file) );
}

if ($pruning)
{
    $graph->prune_nodes_by_label();
    $graph->prune_edges();
}

# get contents of DotGraph
my $graph_out = $graph->get_contents();

# write output graph to stdout
$writer->write_graph($graph_out, \*STDOUT);

