libdeps-perl 0.13-1.1 / usr / share / perl5 / graphincludes / graph.pm

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

package graphincludes::graph;
use strict;
use warnings;

use Hash::Util qw(lock_keys);
use Carp qw(croak);
use DEPS::Node;
use DEPS::Edge;

sub new {
  my $class = shift;
  my $self = {};

  $self->{_NODES} = undef;
  $self->{_EDGES} = undef;
  $self->{_REVEDGES} = undef;

  $self->{_DROPCOUNT} = 0;
  $self->{_DROPPEDEDGES} = {};
  $self->{_DROPPEDREVEDGES} = {};

  bless ($self, $class);
  lock_keys (%$self);
  return $self;
}

sub copy {
  my $self = shift;
  my %args = @_;

  my $class = ref $self;
  my %nodes = %{$self->{_NODES}};
  my $copy = {
	      _NODES => \%nodes,
	      _DROPCOUNT => 0,
	      _EDGES => {},
	      _REVEDGES => {},
	      _DROPPEDEDGES => {},
	      _DROPPEDREVEDGES => {},
	     };

  bless ($copy, $class);

  if (defined $args{deep_copy_edges}) {
    foreach my $src ($self->get_edge_origins) {
      foreach my $dst ($self->get_dep_names_from($src)) {
	$copy->record_edge($src,$dst);
      }
    }
  } else {
    # FIXME: copy mode probably too shallow to make any sense ?
    my (%edges,%revedges);
    %edges = %{$self->{_EDGES}};
    %revedges = %{$self->{_REVEDGES}};
    $copy->{_EDGES} = \%edges;
    $copy->{_REVEDGES} = \%revedges;
  }

  lock_keys (%$copy);
  return $copy;
}

sub set_nodes {
  my $self = shift;

  # store nodes as a hash indexed by label
  my %nodes = map { ($_->{LABEL} => $_) } @_;

  $self->{_NODES} = \%nodes;
}
sub set_nodes_from_names {
  my $self = shift;
  my ($files) = @_;

  $self->set_nodes(map { new DEPS::Node($_); } @$files);
}
sub record_node {
  my $self = shift;
  my ($name) = @_;

  # sanity check
  croak "node name must not be an object or reference" if ref $name;

  $self->{_NODES}{$name} = new DEPS::Node($name)
    unless defined $self->{_NODES}{$name};

  return $self->{_NODES}{$name};
}

sub add_node {
  my $self = shift;
  my ($node) = @_;

  # sanity checks
  unless (ref $node) {
    printf STDERR "Non-object: %s\n", $node->dump;
    croak "Trying to add a non-object as node";
  }
  if (defined $self->{_NODES}{$node->{LABEL}}) {
    printf STDERR "Already have %s\n", $self->{_NODES}{$node->{LABEL}}->dump;
    printf STDERR "Want to add %s\n", $node->dump;
    croak "Cannot add another node labelled $node->{LABEL}";
  }

  $self->{_NODES}{$node->{LABEL}} = $node;
}

sub get_nodes {
  my $self = shift;

  values %{$self->{_NODES}};
}

sub get_node_from_name {
  my $self = shift;
  my ($name) = @_;

  $self->{_NODES}{$name};
}
sub has_node {
  my $self = shift;
  my ($name) = @_;

  defined get_node_from_name($name);
}

sub record_edge {
  my $self = shift;
  my ($src, $dst) = @_;

#   if (defined $self->{IGNOREDDEPS}{$src}{$dst}) {
#     print STDERR "ignoring $src -> $dst\n" if $graphincludes::params::debug;
#     $self->{IGNOREDEDGES}{$src}{$dst} =
#       $self->{IGNOREDDEPS}{$src}{$dst};
#   }

  # sanity check
  croak "edge src name must not be an object or reference" if ref $src;
  croak "edge dst name must not be an object or reference" if ref $dst;

  unless (defined $self->{_EDGES}{$src}{$dst}) {
    # more sanity check
    my $srcnode = $self->{_NODES}{$src}
      or croak "Source node not found '$src'";
    my $dstnode = $self->{_NODES}{$dst}
      or croak "Destination node not found '$dst' (source was '$src')";

    my $edge = new DEPS::Edge ($srcnode, $dstnode);

    $self->{_EDGES}{$src}{$dst} = $self->{_REVEDGES}{$dst}{$src} = $edge;
  }

  return $self->{_EDGES}{$src}{$dst};
}

sub add_edge {
  my $self = shift;
  my ($edge) = @_;

  # sanity checks
  unless (ref $edge) {
    printf STDERR "Non-object: %s\n", $edge;
    croak "Trying to add a non-object as edge";
  }
  if ($self->has_edge($edge->{SRC}{LABEL},$edge->{DST}{LABEL})) {
    printf STDERR "Already have %s\n", $self->get_edge($edge->{SRC}{LABEL},$edge->{DST}{LABEL})->dump;
    printf STDERR "Want to add %s\n", $edge->dump;
    croak "Request to add duplicate edge";
  }

  # do add
  $self->{_EDGES}{$edge->{SRC}{LABEL}}{$edge->{DST}{LABEL}} =
    $self->{_REVEDGES}{$edge->{DST}{LABEL}}{$edge->{SRC}{LABEL}} = $edge;
}

sub has_children {
  my $self = shift;
  my ($src) = @_;

  # FIXME: not 100% correct - that could be an empty hash
  defined $self->{_EDGES}{$src};
}
sub has_parents {
  my $self = shift;
  my ($dst) = @_;

  defined $self->{_REVEDGES}{$dst};
}

sub get_edge {
  my $self = shift;
  my ($src, $dst) = @_;
  return $self->{_EDGES}{$src}{$dst};
}
sub has_edge {
  my $self = shift;
  my ($src, $dst) = @_;
  croak "has_edge: uninitialized src" unless defined $src;
  croak "has_edge: uninitialized dst" unless defined $dst;
  defined $self->{_EDGES}{$src}{$dst};
}
sub has_path {
  my $self = shift;
  my ($from, $to, @seen) = @_;	# @seen is a private parameter
  return ($from) if $from eq $to;
  return () if grep { $_ eq $from } @seen;
  return ($from, $to) if $self->has_edge($from,$to); # superfluous ?
  foreach my $child ($self->get_dep_names_from($from)) {
    if (my @path = $self->has_path($child, $to, (@seen, $from))) {
      return ($from, @path);
    }
  }
  return (); # no child (left) to look at
}

sub drop_edge {
  my $self = shift;
  my ($src, $dst) = @_;

  $self->{_DROPPEDEDGES}{$src}{$dst} = $self->{_EDGES}{$src}{$dst};
  $self->{_DROPPEDREVEDGES}{$dst}{$src} = $self->{_REVEDGES}{$dst}{$src};
  delete $self->{_EDGES}{$src}{$dst};
  delete $self->{_REVEDGES}{$dst}{$src};
}

sub get_edge_origins {
  my $self = shift;
  keys %{$self->{_EDGES}};
}
sub get_edges_from {
  my $self = shift;
  my ($origin) = @_;
  values %{$self->{_EDGES}{$origin}};
}
sub get_dep_names_from {
  my $self = shift;
  my ($origin) = @_;
  keys %{$self->{_EDGES}{$origin}};
}

sub get_edge_weight {
  my $self = shift;
  my ($src,$dst) = @_;
  return $self->get_edge($src,$dst)->weight();
}

sub is_reduction_of {
  my $self = shift;
  my ($complete) = @_;

  print STDERR "Verifying validity of transitive reduction "
    if $graphincludes::params::verbose;

  my $ok = 1;
  foreach my $node ($complete->get_edge_origins) {
    print STDERR '.' if $graphincludes::params::verbose;
    foreach my $child ($complete->get_dep_names_from($node)) {
      if (!$self->has_path($node, $child)) {
	print STDERR "ERROR: missing edge from $node to $child\n"
	  if $graphincludes::params::debug;
	$ok = 0;
      }
    }
  }
  printf STDERR " %s.\n", ($ok ? "ok" : "FAILED")
    if $graphincludes::params::verbose;

  return $ok;
}

1;