File Coverage

blib/lib/Data/Graph/Util.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	16	16	100.0
condition	6	8	75.0
subroutine	10	10	100.0
pod	4	4	100.0
total	110	112	98.2

package Data::Graph::Util;

use 5.010001;
use strict;
use warnings;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2023-12-20'; # DATE
our $DIST = 'Data-Graph-Util'; # DIST
our $VERSION = '0.007'; # VERSION

our @EXPORT_OK = qw(
                       toposort
                       is_cyclic
                       is_acyclic
                       connected_components
               );

sub _toposort {
    my $graph = shift;

    # this is the Kahn algorithm, ref:
    # https://en.wikipedia.org/wiki/Topological_sorting#Kahn.27s_algorithm

    my %in_degree;
    for my $k (keys %$graph) {
        $in_degree{$k} //= 0;
        for (@{ $graph->{$k} }) { $in_degree{$_}++ }
    }

    # collect nodes with no incoming edges (in_degree = 0)
    my @S;
    for (sort keys %in_degree) { unshift @S, $_ if $in_degree{$_} == 0 }

    my @L;
    while (@S) {
        my $n = pop @S;
        push @L, $n;
        for my $m (@{ $graph->{$n} }) {
            if (--$in_degree{$m} == 0) {
                unshift @S, $m;
            }
        }
    }

    if (@L == keys(%$graph)) {
        if (@_) {
            no warnings 'uninitialized';
            # user specifies a list to be sorted according to @L. this is like
            # Sort::ByExample but we implement it ourselves to avoid dependency.
            my %pos;
            for (0..$#L) { $pos{$L[$_]} = $_+1 }
            return (0, [
                sort { ($pos{$a} || @L+1) <=> ($pos{$b} || @L+1) } @{$_[0]}
            ]);
        } else {
            return (0, \@L);
        }
    } else {
        # there is a cycle
        return (1, \@L);
    }
}

sub toposort {
    my ($err, $res) = _toposort(@_);
    die "Can't toposort(), graph is cyclic" if $err;
    @$res;
}

sub is_cyclic {
    my ($err, $res) = _toposort(@_);
    $err;
}

sub is_acyclic {
    my ($err, $res) = _toposort(@_);
    !$err;
}

sub connected_components {
    my $graph = shift;

    # create a map of bidirectional connections between nodes, to ease checking
    my %connections;
    for my $node1 (keys %$graph) {
        for my $node2 (@{ $graph->{$node1} }) {
            $connections{$node1}{$node2} = 1;
            $connections{$node2}{$node1} = 1;
        }
    }

    my @subgraphs;
    my %remaining_nodes = %$graph;

    # traverse a node to get a subgraph. remove the nodes from the original
    # graph. repeat until there are no nodes left on the original graph.

    while (1) { # while there are still unlabeled nodes
        my ($node1, $dependants1) = each %remaining_nodes or last;

        my $subgraph = {$node1 => $dependants1};
        my %seen;
        my @nodes_to_check = keys %{ $connections{$node1} };

        while (@nodes_to_check) { # while we can still find nodes connected to the subgraph
            my $node2 = shift @nodes_to_check;
            next if $seen{$node2}++;
            if (my $dependants2 = delete $remaining_nodes{$node2}) {
                $subgraph->{$node2} = $dependants2;
                push @nodes_to_check, keys %{ $connections{$node2} };
            }
        }

        push @subgraphs, $subgraph;
    }

    sort { scalar(keys %$b) <=> scalar(keys %$a) } @subgraphs;
}

1;
# ABSTRACT: Utilities related to graph data structure

__END__