File Coverage

blib/lib/Data/Graph/Util.pm
Criterion Covered Total %
statement 49 49 100.0
branch 10 10 100.0
condition 6 8 75.0
subroutine 9 9 100.0
pod 3 3 100.0
total 77 79 97.4


line stmt bran cond sub pod time code
1             package Data::Graph::Util;
2              
3             our $DATE = '2019-02-15'; # DATE
4             our $VERSION = '0.006'; # VERSION
5              
6 1     1   597 use 5.010001;
  1         9  
7 1     1   5 use strict;
  1         2  
  1         19  
8 1     1   4 use warnings;
  1         2  
  1         26  
9              
10 1     1   14 use Exporter qw(import);
  1         3  
  1         253  
11             our @EXPORT_OK = qw(toposort is_cyclic is_acyclic);
12              
13             sub _toposort {
14 24     24   44 my $graph = shift;
15              
16             # this is the Kahn algorithm, ref:
17             # https://en.wikipedia.org/wiki/Topological_sorting#Kahn.27s_algorithm
18              
19 24         33 my %in_degree;
20 24         78 for my $k (keys %$graph) {
21 47   100     171 $in_degree{$k} //= 0;
22 47         61 for (@{ $graph->{$k} }) { $in_degree{$_}++ }
  47         84  
  46         88  
23             }
24              
25             # collect nodes with no incoming edges (in_degree = 0)
26 24         37 my @S;
27 24 100       83 for (sort keys %in_degree) { unshift @S, $_ if $in_degree{$_} == 0 }
  57         141  
28              
29 24         38 my @L;
30 24         53 while (@S) {
31 46         77 my $n = pop @S;
32 46         84 push @L, $n;
33 46         59 for my $m (@{ $graph->{$n} }) {
  46         95  
34 35 100       70 if (--$in_degree{$m} == 0) {
35 27         66 unshift @S, $m;
36             }
37             }
38             }
39              
40 24 100       66 if (@L == keys(%$graph)) {
41 19 100       35 if (@_) {
42 1     1   7 no warnings 'uninitialized';
  1         2  
  1         313  
43             # user specifies a list to be sorted according to @L. this is like
44             # Sort::ByExample but we implement it ourselves to avoid dependency.
45 4         5 my %pos;
46 4         10 for (0..$#L) { $pos{$L[$_]} = $_+1 }
  15         26  
47             return (0, [
48 4   66     9 sort { ($pos{$a} || @L+1) <=> ($pos{$b} || @L+1) } @{$_[0]}
  21   66     82  
  4         13  
49             ]);
50             } else {
51 15         53 return (0, \@L);
52             }
53             } else {
54             # there is a cycle
55 5         19 return (1, \@L);
56             }
57             }
58              
59             sub toposort {
60 10     10 1 1466 my ($err, $res) = _toposort(@_);
61 10 100       32 die "Can't toposort(), graph is cyclic" if $err;
62 9         63 @$res;
63             }
64              
65             sub is_cyclic {
66 7     7 1 3965 my ($err, $res) = _toposort(@_);
67 7         30 $err;
68             }
69              
70             sub is_acyclic {
71 7     7 1 3187 my ($err, $res) = _toposort(@_);
72 7         32 !$err;
73             }
74              
75             1;
76             # ABSTRACT: Utilities related to graph data structure
77              
78             __END__
79              
80             =pod
81              
82             =encoding UTF-8
83              
84             =head1 NAME
85              
86             Data::Graph::Util - Utilities related to graph data structure
87              
88             =head1 VERSION
89              
90             This document describes version 0.006 of Data::Graph::Util (from Perl distribution Data-Graph-Util), released on 2019-02-15.
91              
92             =head1 SYNOPSIS
93              
94             use Data::Graph::Util qw(toposort is_cyclic is_acyclic);
95              
96             # return nodes that satisfy the following graph: a must come before b, b must
97             # come before c & d, and d must come before c.
98              
99             my @sorted = toposort(
100             { a=>["b"], b=>["c", "d"], d=>["c"] },
101             ); # => ("a", "b", "d", "c")
102              
103             # sort specified nodes (2nd argument) using the graph. nodes not mentioned in
104             # the graph will be put at the end. duplicates are not removed.
105              
106             my @sorted = toposort(
107             { a=>["b"], b=>["c", "d"], d=>["c"] },
108             ["e", "a", "b", "a"]
109             ); # => ("a", "a", "b", "e")
110              
111             # check if a graph is cyclic
112              
113             say is_cyclic ({a=>["b"]}); # => 0
114             say is_acyclic({a=>["b"]}); # => 1
115              
116             # check if a graph is acyclic (not cyclic)
117              
118             say is_cyclic ({a=>["b"], b=>["c"], c=>["a"]}); # => 1
119             say is_acyclic({a=>["b"], b=>["c"], c=>["a"]}); # => 0
120              
121             =head1 DESCRIPTION
122              
123             Early release. More functions will be added later.
124              
125             Keywords: topological ordering, dependency sorting, dependency ordering.
126              
127             =head1 FUNCTIONS
128              
129             None are exported by default, but they are exportable.
130              
131             =head2 toposort
132              
133             Usage:
134              
135             toposort(\%graph[ , \@nodes ]) => sorted list
136              
137             Perform a topological sort on graph (currently using the Kahn algorithm). Will
138             return the nodes of the graph sorted topologically. Will die if graph cannot be
139             sorted, e.g. when graph is cyclic.
140              
141             If C<\@nodes> is specified, will instead return C<@nodes> sorted according to
142             the topological order. Duplicates are allowed and not removed. Nodes not
143             mentioned in graph are also allowed and will be put at the end.
144              
145             =head2 is_cyclic
146              
147             Usage:
148              
149             is_cyclic(\%graph) => bool
150              
151             Return true if graph contains at least one cycle. Currently implemented by
152             attempting a topological sort on the graph. If it can't be performed, this means
153             the graph contains cycle(s).
154              
155             =head2 is_acyclic
156              
157             Usage:
158              
159             is_acyclic(\%graph) => bool
160              
161             Return true if graph is acyclic, i.e. contains no cycles. The opposite of
162             L</is_cyclic>.
163              
164             =head1 HOMEPAGE
165              
166             Please visit the project's homepage at L<https://metacpan.org/release/Data-Graph-Util>.
167              
168             =head1 SOURCE
169              
170             Source repository is at L<https://github.com/perlancar/perl-Data-Graph-Util>.
171              
172             =head1 BUGS
173              
174             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Graph-Util>
175              
176             When submitting a bug or request, please include a test-file or a
177             patch to an existing test-file that illustrates the bug or desired
178             feature.
179              
180             =head1 SEE ALSO
181              
182             L<https://en.wikipedia.org/wiki/Graph_(abstract_data_type)>
183              
184             L<https://en.wikipedia.org/wiki/Topological_sorting#Kahn.27s_algorithm>
185              
186             L<Algorithm::Dependency> can also do topological sorting, but it is more finicky
187             with input: graph cannot be epmty and all nodes need to be specified.
188              
189             L<Sort::Topological> can also sort a DAG, but cannot handle cyclical graph. It
190             also performs poorly and eats too much RAM on larger graphs.
191              
192             See L<Bencher::Scenario::GraphTopologicalSortModules> for benchmarks.
193              
194             =head1 AUTHOR
195              
196             perlancar <perlancar@cpan.org>
197              
198             =head1 COPYRIGHT AND LICENSE
199              
200             This software is copyright (c) 2019, 2017, 2016 by perlancar@cpan.org.
201              
202             This is free software; you can redistribute it and/or modify it under
203             the same terms as the Perl 5 programming language system itself.
204              
205             =cut