view release on metacpan or  search on metacpan

lib/Graph/TransitiveClosure/Matrix.pm  view on Meta::CPAN

package Graph::TransitiveClosure::Matrix;

use strict;
use warnings;

use Graph::AdjacencyMatrix;
use Graph::Matrix;
use Scalar::Util qw(weaken);
use List::Util qw(min);

sub _A() { 0 } # adjacency
sub _D() { 1 } # distance
sub _S() { 2 } # successors
sub _V() { 3 } # vertices
sub _G() { 4 } # the original graph (OG)

sub _new {
    my ($g, $class, $am_opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices, $want_path_count) = @_;
    my $m = Graph::AdjacencyMatrix->new($g, %$am_opt);
    my @V = $g->vertices;
    my %v2i; @v2i{ @V } = 0..$#V; # paths are in array -> stable ordering
    my $am = $m->adjacency_matrix;
    $am->[1] = \%v2i;
    my ($dm, @di); # The distance matrix.
    my ($sm, @si); # The successor matrix.
    # directly use (not via API) arrays of bit-vectors etc for speed.
    # the API is so low-level it adds no clarity anyway
    my @ai = @{ $am->[0] };
    my $multi = $g->multiedged;
    unless ($want_transitive) {
	$dm = $m->distance_matrix || Graph::Matrix->new($g); # if no distance_matrix in AM, we make our own
	if ($want_path_count) {
	    # force defined
	    @di = map [ (0) x @V ], 0..$#V;
	} else {
	    @di = @{ $dm->[0] };
	}
	$sm = Graph::Matrix->new($g);
	$dm->[1] = $sm->[1] = \%v2i;
	@si = @{ $sm->[0] };
	for (my $iu = $#V; $iu >= 0; $iu--) {
	    vec($ai[$iu], $iu, 1) = 1 if $want_reflexive;
	    for (my $iv = $#V; $iv >= 0; $iv--) {
		next unless vec($ai[$iu], $iv, 1);
		if ($want_path_count or !defined $di[$iu][$iv]) {
		    $di[$iu][$iv] = $iu == $iv ? 0 : 1;
		} elsif ($multi and ref($di[$iu][$iv]) eq 'HASH') {
		    $di[$iu][$iv] = min values %{ $di[$iu][$iv] };
		}
		$si[$iu]->[$iv] = $V[$iv] unless $iu == $iv;
	    }
	}
    }
    # naming here is u = start, v = midpoint, w = endpoint
    for (my $iv = $#V; $iv >= 0; $iv--) {
	my $div = $di[$iv];
	my $aiv = $ai[$iv];
	for (my $iu = $#V; $iu >= 0; $iu--) {
	    my $aiu = $ai[$iu];
	    next if !vec($aiu, $iv, 1);
	    if ($want_transitive) {
		for (my $iw = $#V; $iw >= 0; $iw--) {
		    return 0
			if  $iw != $iv &&
			    vec($aiv, $iw, 1) &&
			   !vec($aiu, $iw, 1);
		}
		next;
	    }
	    my $aiuo = $aiu;
	    $aiu |= $aiv;
	    if ($aiu ne $aiuo) {
		$ai[$iu] = $aiu;
		$aiv = $aiu if $iv == $iu;
	    }
	    next if !$want_path;
	    my $diu = $di[$iu];
	    my $d1a = $diu->[$iv];
	    for (my $iw = $#V; $iw >= 0; $iw--) {
		next unless vec($aiv, $iw, 1);
		if ($want_path_count) {
		    $diu->[$iw]++ if $iu != $iv and $iv != $iw and $iw != $iu;
		    next;
		}
		my $d0  = $diu->[$iw];
		my $d1b = $div->[$iw];
		my $d1 = $d1a + $d1b;
		if (!defined $d0 || ($d1 < $d0)) {
		    # print "d1 = $d1a ($V[$iu], $V[$iv]) + $d1b ($V[$iv], $V[$iw]) = $d1 ($V[$iu], $V[$iw]) (".(defined$d0?$d0:"-").") (propagate=".($aiu ne $aiuo?1:0).")\n";
		    $diu->[$iw] = $d1;
		    $si[$iu]->[$iw] = $si[$iu]->[$iv]
			if $want_path_vertices;
		}
	    }
	}
    }
    return 1 if $want_transitive;
    my %V; @V{ @V } = @V;
    $am->[0] = \@ai;
    $dm->[0] = \@di if defined $dm;
    $sm->[0] = \@si if defined $sm;
    weaken(my $og = $g);
    bless [ $am, $dm, $sm, \%V, $og ], $class;
}

sub new {
    my ($class, $g, %opt) = @_;
    my %am_opt = (distance_matrix => 1);
    $am_opt{attribute_name} = delete $opt{attribute_name}
	if exists $opt{attribute_name};
    $am_opt{distance_matrix} = delete $opt{distance_matrix}
	if $opt{distance_matrix};
    $opt{path_length} = $opt{path_vertices} = delete $opt{path}
	if exists $opt{path};