lib/graphincludes/transform/consolidate.pm

   1 # This file is part of the graph-includes package
   2 #
   3 # (c) 2006 Yann Dirson <ydirson@altern.org>
   4 # Distributed under version 2 of the GNU GPL.
   5
   6 package graphincludes::transform::consolidate;
   7
   8 use warnings;
   9 use strict;
  10
  11 use Set::Object qw();
  12 use Carp qw(croak);
  13 use graphincludes::graph;
  14
  15 sub apply {
  16   my %args = @_;
  17   my $srcs = $args{graphs};
  18
  19   sub _addnodes {
  20     my ($nodeset,$graph) = @_;
  21     foreach my $node ($graph->get_nodes) {
  22       my $newnode = $node->copy;
  23       $newnode->{ORIGINGGRAPH} = $graph;
  24       $nodeset->insert($node);
  25     }
  26   }
  27
  28   my $nodeset = new Set::Object;
  29
  30   # start with all nodes from lower graph
  31   my $prevgraph = $srcs->[0];
  32   _addnodes($nodeset,$prevgraph);
  33
  34   # successively add each other one, lower-to-higher level
  35   my $newgraph;                 # exported from the loop
  36   foreach my $graph (@$srcs[1..$#$srcs]) {
  37     _addnodes($nodeset,$graph);
  38
  39     # sanity check: nodes lower-level graph should not have sub-nodes in
  40     # the set
  41     foreach my $node ($prevgraph->get_nodes) {
  42       foreach my $subnode ($node->get_sub_nodes) {
  43         # FIXME: error message should pinpoint the problem
  44         croak "graphs must be ordered from lower-level to higher-level in graphincludes::transform::consolidate"
  45           if $nodeset->has($subnode);
  46       }
  47     }
  48
  49     my %replacements;           # track to which node each subnode is mapped
  50     # remove all nodes that are subnodes of another
  51     foreach my $node ($graph->get_nodes) {
  52       $nodeset->remove ($node->get_sub_nodes);
  53       foreach my $subnode ($node->get_sub_nodes) {
  54         $replacements{$subnode} = $node;
  55       }
  56     }
  57
  58     $newgraph = new graphincludes::graph;
  59
  60     # add the nodes in the graph
  61     foreach my $node ($nodeset->elements) {
  62       $newgraph->add_node($node);
  63     }
  64
  65     # edges from the top graph
  66     foreach my $src ($graph->get_edge_origins) {
  67       foreach my $edge ($graph->get_edges_from($src)) {
  68         if ($newgraph->has_edge($src, $edge->{DST}{LABEL})) {
  69           # already added, just add sub-edge reference
  70           $newgraph->get_edge($src, $edge->{DST}{LABEL})->add_sub_edge($edge);
  71         } else {
  72           # create new one
  73           $newgraph->add_edge(new graphincludes::edge($graph->get_node_from_name($src),
  74                                                       $edge->{DST})
  75                               ->add_sub_edge($edge));
  76         }
  77       }
  78     }
  79
  80     # add the edges from lower graph, using %replacements
  81     foreach my $src ($prevgraph->get_edge_origins) {
  82       # internal consistency check
  83       croak "edge origin name '$src' is invalid in graph"
  84         unless (defined $prevgraph->get_node_from_name($src));
  85
  86       # look in %replacements to resolve groups,
  87       # then look for a node by that name to catch the ungrouped
  88       my $newsrc = ( $replacements{$prevgraph->get_node_from_name($src)}
  89                      or $newgraph->get_node_from_name($src) );
  90       foreach my $edge ($prevgraph->get_edges_from($src)) {
  91         unless (ref $edge->{DST}) {
  92           use Data::Dumper;
  93           print STDERR "From $src:", Dumper ($prevgraph->get_edges_from($src));
  94           die;
  95         }
  96         my $newdst = ( $replacements{$edge->{DST}}
  97                        or $newgraph->get_node_from_name($edge->{DST}{LABEL}) );
  98
  99         # do not add an edge if there is no match in upper graph
 100         # FIXME: check - does it cause problems when there would be a match at upper+1 ?
 101         unless (defined $newsrc and defined $newdst) {
 102           next;
 103         }
 104
 105         # ignore intra-node deps
 106         next if $newsrc eq $newdst;
 107
 108         if ($newgraph->has_edge($newsrc->{LABEL}, $newdst->{LABEL})) {
 109           # already added, just add sub-edge reference
 110           $newgraph->get_edge($newsrc->{LABEL}, $newdst->{LABEL})->add_sub_edge($edge);
 111         } else {
 112           # create new one
 113           $newgraph->add_edge(new graphincludes::edge($newsrc, $newdst)
 114                               ->add_sub_edge($edge));
 115         }
 116       }
 117     }
 118
 119     $prevgraph = $newgraph;
 120   }
 121
 122
 123   return $newgraph;
 124 }
 125
 126 1;