# This file is part of the DEPS/graph-includes package
#
# (c) 2006 Yann Dirson <ydirson@altern.org>
# Distributed under version 2 of the GNU GPL.

package DEPS::Transform::TransitiveReduction;

use warnings;
use strict;

use graphincludes::graph;
use Carp qw(croak);

sub apply {
  my %args = @_;

  # sanity checks
  if (!defined $args{graphs}
      or scalar @{$args{graphs}} != 1) {
    croak "graphincludes::transform::transitivereduction applies to a single graph";
  }

  my $src = $args{graphs}[0];
  my $reduced = $src->copy(deep_copy_edges => 1);

  print STDERR "Doing transitive reduction " if $graphincludes::params::verbose;
  foreach my $node ($reduced->get_edge_origins) {
    print STDERR '.' if $graphincludes::params::verbose;
    print STDERR "node $node\n" if $graphincludes::params::debug;
    if ($reduced->has_children($node)) {
      my %droppedchildren;	# hash (indexed list) of children to drop

      # first, get the list of children to be dropped
      my @considered = ($node);
      foreach my $child ($reduced->get_dep_names_from($node)) {
	# do not explore children already removed, or some circles cause lost edges
	next if defined $droppedchildren{$child};
	print STDERR " child $child\n" if $graphincludes::params::debug;
	if ($reduced->has_children($child)) {
	  foreach my $gchild ($reduced->get_dep_names_from($child)) {
	    if ($gchild ne $node and $gchild ne $child) { # XXX
	      print STDERR "  gchild $gchild\n" if $graphincludes::params::debug;
	      $reduced->_suppress (\%droppedchildren, $gchild, \@considered,
				   ($node, $child, $gchild));
	    }
	  }
	}
      }

      # then drop those children we just marked
      foreach my $child (keys %droppedchildren) {
	$reduced->drop_edge ($node, $child);
      }
    }
  }
  print STDERR " $reduced->{_DROPCOUNT} cleared.\n" if $graphincludes::params::verbose;

  $reduced->is_reduction_of ($src)
    or die "internal error in transitive reduction (please use --debug)";

  return $reduced;
}


package graphincludes::graph;	# FIXME !

sub _suppress {
  my $self = shift;
  my ($dropped,			# hash (indexed list) of children to drop
      $suspect,			# node to consider this time
      $considered,		# graph nodes already seen, not to reconsider
      @context)			# current path
    = @_;

  # Do not consider $suspect twice, prevent looping on circular deps.
  # We must take care of the special case of the child that led us to
  # the current node, or we would have to do special things to $gchild
  return if $suspect eq $context[1] or grep { $suspect eq $_ } (@$considered);
  push @$considered, $suspect;

  # mark $suspect for removal
  if ($self->has_edge($context[0],$suspect) and !defined $dropped->{$suspect}) {
    if ($graphincludes::params::showdropped) {
      $self->{SPECIALEDGES}{$context[0]}{$suspect} = {color      => "#FFCCCC",
						      constraint => 'false'};
    } elsif (grep { $_ eq $context[0] } @graphincludes::params::focus) {
      $self->{SPECIALEDGES}{$context[0]}{$suspect} = {color => "#FFCCCC"};
    } else {
      $self->{_DROPCOUNT}++;
      # increment "use count" on each step of the alternate path in @context
      my $dropped_edge = $self->get_edge($context[0],$suspect);
      my $weight = $dropped_edge->weight;
      for (my $i = 0; $i < $#context; $i++) {
	$self->{_EDGES}{$context[$i]}{$context[$i+1]}->add_ingredients($dropped_edge);
      }
      # remove it
      $dropped->{$suspect} = 1;
    }
    print STDERR "    --$suspect (", join (',', @context), ")\n" if $graphincludes::params::debug;
  }

  # look at $suspect's children
  if ($self->has_children($suspect)) {
    foreach my $child ($self->get_dep_names_from($suspect)) {
      if ($graphincludes::params::debug) {
	foreach (@context) {
	  print STDERR " ";
	}
	print STDERR "$child\n";
      }
      $self->_suppress ($dropped, $child, $considered, (@context, $child));
    }
  }
}

1;
