├── .github └── workflows │ └── ci.yml ├── .gitignore ├── Changes ├── DESIGN ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── RELEASE ├── TODO ├── lib ├── Graph.pm ├── Graph.pod └── Graph │ ├── AdjacencyMap.pm │ ├── AdjacencyMap │ └── Light.pm │ ├── AdjacencyMatrix.pm │ ├── Attribute.pm │ ├── BitMatrix.pm │ ├── Directed.pm │ ├── MSTHeapElem.pm │ ├── Matrix.pm │ ├── SPTHeapElem.pm │ ├── TransitiveClosure.pm │ ├── TransitiveClosure │ └── Matrix.pm │ ├── Traversal.pm │ ├── Traversal │ ├── BFS.pm │ └── DFS.pm │ ├── Undirected.pm │ └── UnionFind.pm ├── t ├── 00-report-prereqs.t ├── 00_use.t ├── 01_isa.t ├── 02_trap.t ├── 03_derived.t ├── 04_dgraph.t ├── 05_ugraph.t ├── 06_new.t ├── 07_gen.t ├── 08_stringify.t ├── 09_eq.t ├── 10_has_vertices.t ├── 11_vertices.t ├── 12_has_vertex.t ├── 13_add_vertex.t ├── 14_delete_vertex.t ├── 16_edges.t ├── 20_countvertexed.t ├── 21_multivertexed.t ├── 22_refvertexed.t ├── 24_mixvertexed.t ├── 25_countedged.t ├── 26_multiedged.t ├── 30_mixedged.t ├── 33_hyperedge.t ├── 39_edges_at.t ├── 40_edges_from.t ├── 41_edges_to.t ├── 42_add_path.t ├── 45_add_cycle.t ├── 48_get_vertex_count.t ├── 49_get_edge_count.t ├── 50_vertex_attributes.t ├── 51_multivertex_attributes.t ├── 53_multiedge_attributes.t ├── 56_neighbourhood.t ├── 57_degree.t ├── 58_connections.t ├── 59_dfs.t ├── 60_bfs.t ├── 61_connected.t ├── 62_bcc.t ├── 63_scc.t ├── 64_mst.t ├── 65_ref.t ├── 66_simple.t ├── 67_copy.t ├── 71_spt.t ├── 72_transitive.t ├── 73_diameter.t ├── 74_random.t ├── 75_attribute_array.t ├── 76_attribute_hash.t ├── 77_adjacency.t ├── 78_expect.t ├── 79_unionfind.t ├── 80_isomorphic.t ├── 82_cycle.t ├── 83_bitmatrix.t ├── 84_all_cessors.t ├── 85_subgraph.t ├── 86_bipartite.t ├── 87_planar.t ├── 88_max_cliq.t ├── 89_connected_subgraphs.t ├── 99_misc.t ├── MyDGraph.pm ├── MyGraph.pm ├── MyUGraph.pm ├── simple.pl ├── u_at1.t ├── u_at2.t ├── u_at3.t ├── u_bb_rv.t ├── u_bf.t ├── u_bill.t ├── u_bo_ap1.t ├── u_bo_ap2.t ├── u_bo_apx.t ├── u_cd_rv.t ├── u_dl_uf.t ├── u_jh_va.t ├── u_mn_va.t ├── u_ng_mst.t ├── u_ng_path.t ├── u_ng_scc.t ├── u_rb_cc.t ├── u_re_sd.t ├── u_ro_ra.t ├── u_sc_me.t ├── u_te_ea.t └── u_te_me.t ├── util ├── cover.sh ├── grand.pl ├── size.pl └── srand.sh └── xt ├── manifest.t ├── pod-coverage.t └── pod.t /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: perl 2 | on: 3 | push: 4 | branches: 5 | - '*' 6 | tags-ignore: 7 | - '*' 8 | pull_request: 9 | jobs: 10 | ubuntu: 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: [ubuntu-latest] 16 | perl-version: ['5.8-buster', '5.14-buster', '5.20-buster'] 17 | include: 18 | - perl-version: 'latest' 19 | os: ubuntu-latest 20 | release-test: true 21 | coverage: true 22 | container: perl:${{ matrix.perl-version }} 23 | steps: 24 | - uses: actions/checkout@v2 25 | - run: cpanm -n --with-recommends --installdeps . 26 | - run: perl -V 27 | - name: Run release tests # before others as may install useful stuff 28 | if: ${{ matrix.release-test }} 29 | env: 30 | RELEASE_TESTING: 1 31 | run: | 32 | cpanm -n --installdeps --with-develop . 33 | prove -lr xt 34 | - name: Run tests (no coverage) 35 | if: ${{ !matrix.coverage }} 36 | run: prove -l -j4 t 37 | - name: Run tests (with coverage) 38 | if: ${{ matrix.coverage }} 39 | env: 40 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 41 | run: | 42 | git config --global --add safe.directory /__w/Graph/Graph 43 | cpanm -n Devel::Cover::Report::Coveralls 44 | HARNESS_OPTIONS='j4' cover -test -report Coveralls 45 | non-linux: 46 | runs-on: ${{ matrix.os }} 47 | strategy: 48 | fail-fast: false 49 | matrix: 50 | os: [macos-latest, windows-latest] 51 | steps: 52 | - uses: actions/checkout@v2 53 | - uses: shogo82148/actions-setup-perl@v1 54 | with: 55 | distribution: strawberry # ignored non-windows 56 | - uses: perl-actions/install-with-cpanm@v1 57 | with: 58 | args: -n --installdeps . 59 | - run: perl -V 60 | - name: Run tests 61 | run: prove -l -j4 t 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | MYMETA.json 2 | MYMETA.yml 3 | Makefile 4 | blib/ 5 | pm_to_blib 6 | cover_db/ 7 | nytprof.out 8 | nytprof/ 9 | -------------------------------------------------------------------------------- /DESIGN: -------------------------------------------------------------------------------- 1 | *** NOTE THAT THE INTERNALS OF GRAPH 0.50 ARE COMPLEX *** 2 | *** AND (ALMOST INTENTIONALLY) UNDERDOCUMENTED. *** 3 | *** YOU ARE NOT SUPPOSED TO BE ABLE TO ACCESS *** 4 | *** THE INTERNALS DIRECTLY. *** 5 | 6 | The design goals of Graph 0.5 were flexibility and being able to 7 | represent even the more unusual graphs like graphs with reference-counted 8 | edges and vertices, multi(edge or vertex)graphs (an edge or vertex can 9 | "be present" more than once), hyper(edge)graphs (an edge can join more 10 | than two edges), and hypervertexgraphs (vertices of more than one, errm, 11 | vertex). 12 | 13 | As you can see (or rather, not see) being fast was not a design goal. 14 | 15 | Note that while the underlying data structures can do the above 16 | (and even a little bit beyond those), the common graph algorithms 17 | don't either (at best) understand at all the more esoteric graphs, 18 | or (at worst) break horribly, either by producing wrong results, 19 | crashing, or looping infinitely (isn't it nice to have options?). 20 | It is hoped that the people needing algorithms on the more esoteric 21 | graphs will write their own algorithms or enhance the current ones to 22 | cope better. 23 | 24 | While the data structures (into which we will get in a moment) 25 | are flexible, extra care was taken to optimize the common case 26 | (your usual non-counted non-hyper graphs) so that too much time 27 | memory isn't wasted in being overly general. Some waste does 28 | happen, so in general the code is 2-4 times slower than the 29 | previous generation, Graph 0.2xxx. 30 | 31 | Another complicating factor not really stemming from graph theory but 32 | from Perl itself was that some people wanted to be able to have Perl 33 | objects that have stringify overload as graph vertices. Also this is 34 | now possible (the "refvertexed" parameter), at least based on very 35 | light testing. It is very likely, though, that in some corners of the 36 | code this will still not work (it requires an extra step in handling 37 | vertices, and I quite probably forgot some spots). 38 | 39 | The most basic data structure of Graphs is a Map. A map consists of 40 | zero or more 'coordinates' and a data item that can be found by 41 | following the set of coordinates. The data item can also be missing 42 | which means that the set of coordinates exists. The set of 43 | coordinates can be ordered or unordered, and it can also be 44 | "uniquefying" or not on the coordinates. For the vertices the 45 | coordinates are strings, but there is a mapping from those strings to 46 | integers, and the edge coordinates use those integers. Maps come in 47 | different complexities: light, vertex, and heavy. A 'light' map is 48 | used if the elements have nothing fancy like for example attributes 49 | (it is basically just using a hash for the vertices and a hash of 50 | hashes for the edges), a 'heavy' map is used if they do. A 'vertex' 51 | map is a simplified version of a 'heavy' map used only for 'normal' 52 | (non-hyper) vertices. 53 | 54 | A vertex is an AdjacencyMap of one coordinate, an edge is a AdjacencyMap 55 | of two coordinates. (If we are talking about non-hyper cases.) 56 | 57 | Therefore an ordinary Graph is at its heart a tuple of AdjacencyMaps 58 | or in familiar terms (V, E). 59 | 60 | The rather complex design means that one is not really able (not without 61 | considerable and future-fragile effort) to derive from Graph and expect 62 | to be able to directly access and manipulate the internal data structures. 63 | 64 | Multiplicity in its most basic form is handled by having an additional 65 | counter for an (AdjacencyMap) item and then incrementing and 66 | decrementing that appropriately. When the counter goes to zero, 67 | a full delete takes place: this is called countvertexed/countedged. 68 | To be really "multi" each vertex or edge needs to have its own 69 | identity and existence and to be able to store its own data: this is 70 | called multivertexed/multiedged. 71 | 72 | The hyperness is handled by having separate slots for each 73 | AdjacencyMap item arity: zero, one (for vertices), two (for edges), 74 | and so forth. 75 | 76 | Both the multiplicity (count/multi) and hyperness are set up on demand 77 | when those features are requested at Graph creation, in the normal 78 | case the data structures are as simple as possible. The implementation 79 | is done by switching the internal implementation between ::Light, 80 | ::Vertex, and ::Heavy classes. This is all done automatically 81 | and internally AND ONE IS NOT SUPPOSED TO USE THOSE CLASSES DIRECTLY. 82 | 83 | Attributes are part of (non-'light') AdjacencyMaps, this means that 84 | each vertex and edge can have its own attributes. Also Graphs can 85 | have attributes, but unfortunately Graph attributes do not currently 86 | use the AdjacencyMap abstraction for storing their attributes. 87 | 88 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | DESIGN 3 | lib/Graph.pm 4 | lib/Graph.pod 5 | lib/Graph/AdjacencyMap.pm 6 | lib/Graph/AdjacencyMap/Light.pm 7 | lib/Graph/AdjacencyMatrix.pm 8 | lib/Graph/Attribute.pm 9 | lib/Graph/BitMatrix.pm 10 | lib/Graph/Directed.pm 11 | lib/Graph/Matrix.pm 12 | lib/Graph/MSTHeapElem.pm 13 | lib/Graph/SPTHeapElem.pm 14 | lib/Graph/TransitiveClosure.pm 15 | lib/Graph/TransitiveClosure/Matrix.pm 16 | lib/Graph/Traversal.pm 17 | lib/Graph/Traversal/BFS.pm 18 | lib/Graph/Traversal/DFS.pm 19 | lib/Graph/Undirected.pm 20 | lib/Graph/UnionFind.pm 21 | Makefile.PL 22 | MANIFEST This list of files 23 | README 24 | RELEASE 25 | t/00-report-prereqs.t 26 | t/00_use.t 27 | t/01_isa.t 28 | t/02_trap.t 29 | t/03_derived.t 30 | t/04_dgraph.t 31 | t/05_ugraph.t 32 | t/06_new.t 33 | t/07_gen.t 34 | t/08_stringify.t 35 | t/09_eq.t 36 | t/10_has_vertices.t 37 | t/11_vertices.t 38 | t/12_has_vertex.t 39 | t/13_add_vertex.t 40 | t/14_delete_vertex.t 41 | t/16_edges.t 42 | t/20_countvertexed.t 43 | t/21_multivertexed.t 44 | t/22_refvertexed.t 45 | t/24_mixvertexed.t 46 | t/25_countedged.t 47 | t/26_multiedged.t 48 | t/30_mixedged.t 49 | t/33_hyperedge.t 50 | t/39_edges_at.t 51 | t/40_edges_from.t 52 | t/41_edges_to.t 53 | t/42_add_path.t 54 | t/45_add_cycle.t 55 | t/48_get_vertex_count.t 56 | t/49_get_edge_count.t 57 | t/50_vertex_attributes.t 58 | t/51_multivertex_attributes.t 59 | t/53_multiedge_attributes.t 60 | t/56_neighbourhood.t 61 | t/57_degree.t 62 | t/58_connections.t 63 | t/59_dfs.t 64 | t/60_bfs.t 65 | t/61_connected.t 66 | t/62_bcc.t 67 | t/63_scc.t 68 | t/64_mst.t 69 | t/65_ref.t 70 | t/66_simple.t 71 | t/67_copy.t 72 | t/71_spt.t 73 | t/72_transitive.t 74 | t/73_diameter.t 75 | t/74_random.t 76 | t/75_attribute_array.t 77 | t/76_attribute_hash.t 78 | t/77_adjacency.t 79 | t/78_expect.t 80 | t/79_unionfind.t 81 | t/80_isomorphic.t 82 | t/82_cycle.t 83 | t/83_bitmatrix.t 84 | t/84_all_cessors.t 85 | t/85_subgraph.t 86 | t/86_bipartite.t 87 | t/87_planar.t 88 | t/88_max_cliq.t 89 | t/89_connected_subgraphs.t 90 | t/99_misc.t 91 | t/MyDGraph.pm 92 | t/MyGraph.pm 93 | t/MyUGraph.pm 94 | t/simple.pl 95 | t/u_at1.t 96 | t/u_at2.t 97 | t/u_at3.t 98 | t/u_bb_rv.t 99 | t/u_bf.t 100 | t/u_bill.t 101 | t/u_bo_ap1.t 102 | t/u_bo_ap2.t 103 | t/u_bo_apx.t 104 | t/u_cd_rv.t 105 | t/u_dl_uf.t 106 | t/u_jh_va.t 107 | t/u_mn_va.t 108 | t/u_ng_mst.t 109 | t/u_ng_path.t 110 | t/u_ng_scc.t 111 | t/u_rb_cc.t 112 | t/u_re_sd.t 113 | t/u_ro_ra.t 114 | t/u_sc_me.t 115 | t/u_te_ea.t 116 | t/u_te_me.t 117 | TODO 118 | util/cover.sh 119 | util/grand.pl 120 | util/size.pl 121 | util/srand.sh 122 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Avoid version control files. 2 | ,v$ 3 | \B\.cvsignore$ 4 | \B\.git\b 5 | \B\.gitignore\b 6 | \B\.svn\b 7 | \bCVS\b 8 | \bRCS\b 9 | 10 | # Avoid Makemaker generated and utility files. 11 | \bblib 12 | \bblibdirs$ 13 | \bpm_to_blib$ 14 | \bMakefile$ 15 | \bMakeMaker-\d 16 | 17 | # Avoid Module::Build generated and utility files. 18 | \b_build 19 | \bBuild$ 20 | \bBuild.bat$ 21 | 22 | # Avoid Devel::Cover generated files 23 | \bcover_db 24 | 25 | # Avoid temp and backup files. 26 | ~$ 27 | \#$ 28 | \.# 29 | \.bak$ 30 | \.old$ 31 | \.rej$ 32 | \.tmp$ 33 | 34 | # Avoid OS-specific files/dirs 35 | # Mac OSX metadata 36 | \B\.DS_Store 37 | # Mac OSX SMB mount metadata files 38 | \B\._ 39 | 40 | # Avoid UltraEdit files. 41 | \.prj$ 42 | \.pui$ 43 | 44 | ^MYMETA\. 45 | 46 | ^Graph-.* 47 | \.swp$ 48 | 49 | ^\.github/ 50 | ^MANIFEST\.SKIP$ 51 | ^xt/ 52 | ^nytprof\.out 53 | ^nytprof/ 54 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use ExtUtils::MakeMaker; 3 | 4 | require 5.006; 5 | 6 | my $mm_ver = $ExtUtils::MakeMaker::VERSION; 7 | if ($mm_ver =~ /_/) { # dev version 8 | $mm_ver = eval $mm_ver; 9 | die $@ if $@; 10 | } 11 | 12 | my %PREREQ_PM = ( 13 | 'List::Util' => '1.45', 14 | 'Scalar::Util' => 0, 15 | 'Heap' => '0.80', 16 | 'Set::Object' => '1.40', 17 | ); 18 | 19 | if ($] >= 5.008) { 20 | $PREREQ_PM{'Storable'} = '2.05'; 21 | $PREREQ_PM{'Safe' } = 0, 22 | } 23 | 24 | my $repo = 'graphviz-perl/Graph'; 25 | WriteMakefile( 26 | NAME => 'Graph', 27 | VERSION_FROM => 'lib/Graph.pm', 28 | PREREQ_PM => \%PREREQ_PM, 29 | AUTHOR => 'Jarkko Hietaniemi ', 30 | 31 | ($mm_ver >= 6.31 32 | ? (LICENSE => 'perl') 33 | : () 34 | ), 35 | 36 | ($mm_ver >= 6.48 37 | ? (MIN_PERL_VERSION => 5.006) 38 | : () 39 | ), 40 | 41 | ($mm_ver <= 6.45 42 | ? () 43 | : (META_MERGE => { 44 | 'meta-spec' => { version => 2 }, 45 | resources => { 46 | bugtracker => { web => "https://github.com/$repo/issues" }, 47 | repository => { 48 | type => 'git', 49 | web => "https://github.com/$repo", 50 | url => "git://github.com/$repo.git", 51 | }, 52 | }, 53 | prereqs => { 54 | develop => { 55 | requires => { 56 | 'Test::Pod::Coverage' => '1.00', 57 | 'Test::Pod' => '1.00', 58 | }, 59 | }, 60 | test => { 61 | requires => { 62 | 'Test::More' => '0.82', # explain 63 | 'Math::Complex' => 0, 64 | }, 65 | recommends => { 66 | 'App::Prove' => '3.00', # prove -j4 67 | }, 68 | }, 69 | }, 70 | }) 71 | ), 72 | ); 73 | 74 | # Some Debian distributions have a broken List::Util (see rt.cpan.org #9568) 75 | eval 'require Scalar::Util; import Scalar::Util qw(weaken)'; 76 | if ($@) { 77 | die <<__EOF__; 78 | $@ 79 | You do not have Scalar::Util::weaken, cannot continue, aborting. 80 | __EOF__ 81 | } 82 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | README for Perl module Graph 2 | 3 | This is Graph, a Perl module for dealing with graphs, the abstract 4 | data structures. (If you were looking for pie charts, I'm sorry.) 5 | 6 | This is a full rewrite of the Graph module 0.2xx series as discussed 7 | in the book "Mastering Algorithms with Perl", written by Jarkko 8 | Hietaniemi (the undersigned), John Macdonald, and Jon Orwant, 9 | and published by O'Reilly and Associates. This rewrite is not 10 | fully compatible with the 0.2xx series, simply because I did 11 | not want to carry over all the design flaws and bugs. 12 | 13 | Test cases of all sizes to keep me honest are warmly welcomed. 14 | 15 | For the changes, read Changes. 16 | 17 | For the release notes, read RELEASE. 18 | 19 | If you find bugs, please distill your test case to the absolute minimum 20 | and report it, preferably via http://rt.cpan.org/NoAuth/Bugs.html?Dist=Graph 21 | 22 | This module was written by 23 | 24 | Jarkko Hietaniemi 25 | jhi@iki.fi 26 | 27 | Jarkko has moved onto other things, so now I'm maintaining this distribution. 28 | I have no great plans for it, but will try to address any bugs reported, 29 | and follow all modern conventions, etc. Pull requests and patches most welcome :-) 30 | 31 | Neil Bowers 32 | neil@cpan.org 33 | 34 | -------------------------------------------------------------------------------- /RELEASE: -------------------------------------------------------------------------------- 1 | 0.50 2 | 3 | * THIS IS NOT COMPATIBLE with the old 0.2xxx series of the Graph 4 | module. Your scripts are likely to break. I did try to fashion a 5 | nice compatibility mode but there was no way to do that cleanly 6 | and to cover all the old oddities. You can try the compatibility 7 | mode but I suggest changing your code instead because the compat 8 | mode is not going to be carried over to the next releases of the 9 | module. 10 | 11 | * The main reason for introducing the incompatibilities was that 12 | the new Graph supports graphs of 'higher dimensions', and the 13 | assumptions made by the old module (most importantly that edges 14 | could only span two vertices) in effect made it impossible to 15 | extend the interfaces. 16 | 17 | * The most serious incompatibility is edges(): with the old 18 | way in list context it returned the vertices of the edges as a 19 | flat list. Now it returns a list of anonymous arrays that contain 20 | the vertices for each edge. 21 | 22 | * vertices() now returns the vertices in an undefined order. 23 | 24 | * This release does not worry much about speed (some inlining 25 | of the "hot paths" has been done, however), but instead 26 | about correctness and documentation. Everything is probably 27 | slower than 0.2xx by a factor of two to five, or worse. 28 | 29 | * The average size of an empty graph is about 1160 bytes. 30 | * The average size per vertex is about 110 bytes. 31 | * The average size per edge is about 390 bytes. 32 | * These figures are for a 32-bit Perl. 33 | 34 | * If you want speed (or especially if you want small memory 35 | footprint), you shouldn't be using pure Perl. Consider using 36 | things like PDL (pdl.perl.org), XS interfaces to LEDA or Boost Graph 37 | libraries (no, I don't know of such interfaces), or build your own 38 | algorithms on top of Bit::Vector, or resort non-Perl solutions 39 | like MATLAB or Mathematica, or again LEDA or Boost. 40 | 41 | * The current implementation of Graph objects is decidedly 42 | non-trivial (see DESIGN), which means that you cannot extend 43 | it in trivial ways (e.g. access vertices of a graph as keys 44 | in a hash). But you shouldn't be doing things like that anyway, 45 | peeking and poking at objects' innards, right? 46 | 47 | * The next version of Graph (most likely 0.90) is going to aim 48 | for speed. The backward compatibility for the 0.2xxx series 49 | will be dropped (because that, too, slows down this release). 50 | 51 | * No DAG SSSP has been implemented for this release. 52 | Dijkstra and Bellman-Ford SSSPs are available, though. 53 | 54 | * No flow network algorithms (like Ford-Fulkerson) have been 55 | implemented for this release. This omission will no doubt bring 56 | out from the woodwork all the myriad users of flow networks. 57 | 58 | * This release depends on the List::Util module, part of Perl 59 | releases since Perl 5.8.0, or available from the CPAN. (Also the 60 | Heap module is required, as it was already with Graph 0.2xxx.) 61 | 62 | * This release requires at least Perl 5.005, a step up from 63 | 5.004_04 as required by 0.2xx. (I just don't have 5.004 64 | installed any more, so I simply wasn't able to test this 65 | release with 5.004.) 66 | 67 | -- 68 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Note that these are possibilities, not plans nor promises. 2 | 3 | - graph periphery: the subgraph of graph center vertices 4 | - finding the shortest cycle: easy for directed (*), but how about undirected? 5 | (*) http://www.cs.auckland.ac.nz/~ute/220ft/graphalg/node14.html 6 | do a BFS, when sees an already seen vertex, a cycle of length of at most 7 | twice the current depth of the BFS has been found; no cycles => V + 1 (Inf) 8 | - bipartite aka 2-colourable: again, BFS: 9 | http://www.cs.auckland.ac.nz/~ute/220ft/graphalg/node15.html 10 | - Eulerian circuit: Fleury's algorithm: 11 | http://planetmath.org/encyclopedia/FleurysAlgorithm.html 12 | - could_be_isomorphic() - go second degree? 13 | 14 | 1. separate external and internal attributes? 15 | 2. biconn: add next_root 16 | 3. DAG SSSP 17 | 4. flow: Ford-Fulkerson/Edmonds-Karp/preflow-push? Floyd-Warshall variant? 18 | 19 | -- Classics -- 20 | 21 | Undirected graphs 22 | - connectivity 23 | - given two vertices are they on a cycle 24 | - find_all_paths($u, $v)? 25 | - find_all_cycles()? NP-complete; equivalent to finding all Hamiltonians 26 | - Euler tour 27 | 28 | Digraphs 29 | - disallow_selfloops => 1? 30 | - odd-length cycle 31 | - shortest paths (bfs) 32 | - squaring a graph: for (u,v)(v,w) add (u,w) unless already there 33 | 34 | - graph union, graph difference? 35 | 36 | Various specialized graph constructors? 37 | - n-dim grid (with wraps and connectors -> wheels (webs), cones), 38 | circle, star, platonic solids, trees, etc. 39 | -------------------------------------------------------------------------------- /lib/Graph/AdjacencyMap/Light.pm: -------------------------------------------------------------------------------- 1 | package Graph::AdjacencyMap::Light; 2 | 3 | # THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY. 4 | # THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND 5 | # ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES. 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use Graph::AdjacencyMap qw(:flags :fields); 11 | use base 'Graph::AdjacencyMap'; 12 | 13 | # $SIG{__DIE__ } = \&Graph::__carp_confess; 14 | # $SIG{__WARN__} = \&Graph::__carp_confess; 15 | 16 | my @LOCAL_OVERRIDE = (_s, _p); 17 | 18 | sub _is_COUNT () { 0 } 19 | sub _is_MULTI () { 0 } 20 | sub _is_REF () { 0 } 21 | 22 | sub _new { 23 | my ($class, $flags, $arity) = @_; 24 | (my $m = $class->SUPER::_new($flags | _LIGHT, $arity))->[ _attr ] = {}; 25 | @$m[ @LOCAL_OVERRIDE ] = map $m->[ $_ ] ? [] : undef, @LOCAL_OVERRIDE; 26 | $m; 27 | } 28 | 29 | sub set_paths { 30 | my ($m, @paths) = @_; 31 | my ($f, $a, $i, $pi, $map_s, $map_p, @ids) = (@$m[ _f, _arity, _i, _pi, _s, _p ]); 32 | for (@paths) { 33 | my $k = $_; 34 | Graph::__carp_confess("Wrong number of args, want $a, got (@$k)") if $a != 1 and $a != @$k; 35 | my $l = $a == 1 ? $k : join ' ', @$k; 36 | push(@ids, $pi->{ $l }), next if defined $pi->{ $l }; 37 | $i->[ my $n = $m->[ _n ]++ ] = $_; 38 | $pi->{ $l } = $n; 39 | push @ids, $n; 40 | _successors_add($f, $map_s, $map_p, $n, $_) if $map_s; 41 | } 42 | @ids; 43 | } 44 | 45 | sub _successors_set { 46 | my $val = pop; 47 | my ($f, $map_s, $map_p, $id, $path) = @_; 48 | my $pairs = Graph::AdjacencyMap::_successors_cartesian(($f & _UNORD), 0, $path); 49 | no warnings 'uninitialized'; # needed 5.8 50 | vec($map_s->[ $_->[0] ], $_->[1], 1) = $val for @$pairs; # row-major 51 | return if !$map_p; 52 | vec($map_p->[ $_->[1] ], $_->[0], 1) = $val for @$pairs; 53 | } 54 | sub _successors_add { push @_, 1; goto &_successors_set } 55 | sub _successors_del { push @_, 0; goto &_successors_set } 56 | 57 | sub _paths_fromto { 58 | my $offset = pop; 59 | my ($i, $pi, $f, $map_x, @v) = ( @{ $_[0] }[ _i, _pi, _f, $offset ], @_[1..$#_] ); 60 | Graph::__carp_confess("undefined vertex") if grep !defined, @v; 61 | require Set::Object; 62 | my ($paths, $invert, $unord) = (Set::Object->new, $offset == _p, $f & _UNORD); 63 | for my $tuple (grep defined $_->[1], map [$_, $map_x->[$_]], @v) { 64 | my ($v, $s) = ($tuple->[0], scalar unpack("b*", $tuple->[1])); 65 | $paths->insert(join ' ', ( 66 | $unord ? sort($v, pos($s) - 1) : 67 | $invert ? (pos($s) - 1, $v) : ($v, pos($s) - 1) 68 | )) while $s =~ /1/g; 69 | } 70 | map $i->[ $pi->{ $_ } ], $paths->members; 71 | } 72 | sub paths_from { push @_, _s; goto &_paths_fromto } 73 | sub paths_to { push @_, _p; goto &_paths_fromto } 74 | 75 | sub _cessors { 76 | my $offset = pop; 77 | my ($map_x, @v) = ( @{ $_[0] }[ $offset ], @_[1..$#_] ); 78 | Graph::__carp_confess("undefined vertex") if grep !defined, @v; 79 | require Set::Object; 80 | my $c = Set::Object->new; 81 | for my $row (grep defined, @$map_x[ @v ]) { 82 | # 10x quicker than: grep vec($row, $_, 1), 0..$#$m 83 | my $s = unpack("b*", $row); 84 | $c->insert(pos($s) - 1) while $s =~ /1/g; 85 | } 86 | $c->members; 87 | } 88 | sub successors { push @_, _s; goto &_cessors } 89 | sub predecessors { push @_, _p; goto &_cessors } 90 | 91 | sub has_successor { 92 | my ($map_s, $u, $v) = ( @{ $_[0] }[ _s ], @_[1, 2] ); 93 | Graph::__carp_confess("undefined vertex") if grep !defined, $u, $v; 94 | vec(($map_s->[ $u ] || return 0), $v, 1); 95 | } 96 | 97 | sub get_ids_by_paths { 98 | my ($pi, $m, $list, $ensure, $deep) = ( @{ $_[0] }[ _pi ], @_ ); 99 | $deep ||= 0; 100 | map { 101 | my @ret = map { 102 | my @ret2 = map { 103 | my $id = $pi->{ $_ }; 104 | defined $id ? $id : $ensure ? $m->set_paths($_) : return; 105 | } $deep > 1 ? @$_ : $_; 106 | $deep > 1 ? \@ret2 : @ret2; 107 | } $deep ? @$_ : $_; 108 | $deep ? \@ret : @ret; 109 | } @$list; 110 | } 111 | 112 | sub has_path { 113 | my ($a, $pi, $k) = ( @{ $_[0] }[ _arity, _pi ], $_[1] ); 114 | Graph::__carp_confess("Wrong number of args, want $a, got (@$k)") if $a != 1 and $a != @$k; 115 | $pi->{ $a == 1 ? $k : join ' ', @$k }; 116 | } 117 | 118 | sub _get_path_count { 119 | defined(my $dummy = &has_path) ? 1 : 0; # defined &x asks if func defined 120 | } 121 | 122 | sub del_path { 123 | my ($f, $a, $i, $pi, $map_s, $map_p, $attr, $k) = ( @{ my $m = $_[0] }[ _f, _arity, _i, _pi, _s, _p, _attr ], $_[1] ); 124 | Graph::__carp_confess("Wrong number of args, want $a, got (@$k)") if $a != 1 and $a != @$k; 125 | my $l = $a == 1 ? $k : join ' ', @$k; 126 | return 0 if !exists $pi->{ $l }; 127 | my $id = delete $pi->{ $l }; 128 | delete $attr->{ $l }; 129 | my $path = delete $i->[ $id ]; 130 | _successors_del($f, $map_s, $map_p, $id, $path) if $map_s; 131 | return 1; 132 | } 133 | 134 | sub rename_path { 135 | my ($m, $from, $to) = @_; 136 | my ($a, $i, $pi, $attr) = @$m[ _arity, _i, _pi, _attr ]; 137 | return 1 if $a > 1; # arity > 1, all integers, no names 138 | return 0 unless exists $pi->{ $from }; 139 | $attr->{ $to } = delete $attr->{ $from } if $attr->{ $from }; 140 | $i->[ $pi->{ $to } = delete $pi->{ $from } ] = $to; 141 | return 1; 142 | } 143 | 144 | sub _set_path_attr_common { 145 | (my $m = $_[0])->set_paths($_[1]); 146 | my ($a, $attr, $k) = ( @$m[ _arity, _attr ], $_[1] ); 147 | my $l = $a == 1 ? $k : join ' ', @$k; 148 | \$attr->{ $l }; 149 | } 150 | 151 | sub _get_path_attrs { 152 | my ($a, $attr, $k) = ( @{ $_[0] }[ _arity, _attr ], $_[1] ); 153 | Graph::__carp_confess("Wrong number of args, want $a, got (@$k)") if $a != 1 and $a != @$k; 154 | my $l = $a == 1 ? $k : join ' ', @$k; 155 | $attr->{ $l }; 156 | } 157 | 158 | sub _del_path_attrs { 159 | return undef unless defined &has_path; 160 | my ($a, $attr, $k) = ( @{ $_[0] }[ _arity, _attr ], $_[1] ); 161 | my $l = $a == 1 ? $k : join ' ', @$k; 162 | return 0 unless exists $attr->{ $l }; 163 | delete $attr->{ $l }; 164 | 1; 165 | } 166 | 167 | 1; 168 | -------------------------------------------------------------------------------- /lib/Graph/AdjacencyMatrix.pm: -------------------------------------------------------------------------------- 1 | package Graph::AdjacencyMatrix; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Graph::BitMatrix; 7 | use Graph::Matrix; 8 | 9 | use base 'Graph::BitMatrix'; 10 | 11 | use Graph::AdjacencyMap qw(:flags :fields); 12 | 13 | sub _AM () { 0 } 14 | sub _DM () { 1 } 15 | sub _V () { 2 } # Graph::_V 16 | sub _E () { 3 } # Graph::_E 17 | 18 | sub new { 19 | my ($class, $g, %opt) = @_; 20 | my @V = $g->vertices; 21 | my $want_distance = delete $opt{distance_matrix}; 22 | my $d = Graph::_defattr(); 23 | if (exists $opt{attribute_name}) { 24 | $d = delete $opt{attribute_name}; 25 | $want_distance++; 26 | } 27 | my $want_transitive = delete $opt{is_transitive}; 28 | Graph::_opt_unknown(\%opt); 29 | my $m = Graph::BitMatrix->new($g); 30 | my $self = bless [ $m, undef, \@V ], $class; 31 | return $self if !$want_distance; 32 | my $n = $self->[ _DM ] = Graph::Matrix->new($g); 33 | $n->set($_, $_, 0) for @V; 34 | my $n0 = $n->[0]; 35 | my $n1 = $n->[1]; 36 | my $undirected = $g->is_undirected; 37 | my $multiedged = $g->multiedged; 38 | for my $e ($g->edges) { 39 | my ($u, $v) = @$e; 40 | $n->set($u, $v, $multiedged 41 | ? _multiedged_distances($g, $u, $v, $d) 42 | : $g->get_edge_attribute($u, $v, $d) 43 | ); 44 | $n->set($v, $u, $multiedged 45 | ? _multiedged_distances($g, $v, $u, $d) 46 | : $g->get_edge_attribute($v, $u, $d) 47 | ) if $undirected; 48 | } 49 | $self; 50 | } 51 | 52 | sub _multiedged_distances { 53 | my ($g, $u, $v, $attr) = @_; 54 | my %r; 55 | for my $id ($g->get_multiedge_ids($u, $v)) { 56 | my $w = $g->get_edge_attribute_by_id($u, $v, $id, $attr); 57 | $r{$id} = $w if defined $w; 58 | } 59 | keys %r ? \%r : undef; 60 | } 61 | 62 | sub adjacency_matrix { $_[0]->[ _AM ] } 63 | 64 | sub distance_matrix { $_[0]->[ _DM ] } 65 | 66 | sub vertices { @{ $_[0]->[ _V ] } } 67 | 68 | sub is_adjacent { 69 | my ($m, $u, $v) = @_; 70 | $m->[ _AM ]->get($u, $v) ? 1 : 0; 71 | } 72 | 73 | sub distance { 74 | my ($m, $u, $v) = @_; 75 | defined $m->[ _DM ] ? $m->[ _DM ]->get($u, $v) : undef; 76 | } 77 | 78 | 1; 79 | __END__ 80 | =pod 81 | 82 | =head1 NAME 83 | 84 | Graph::AdjacencyMatrix - create and query the adjacency matrix of graph G 85 | 86 | =head1 SYNOPSIS 87 | 88 | use Graph::AdjacencyMatrix; 89 | use Graph::Directed; # or Undirected 90 | 91 | my $g = Graph::Directed->new; 92 | $g->add_...(); # build $g 93 | 94 | my $am = Graph::AdjacencyMatrix->new($g); 95 | $am->is_adjacent($u, $v) 96 | 97 | my $am = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); 98 | $am->distance($u, $v) 99 | 100 | my $am = Graph::AdjacencyMatrix->new($g, attribute_name => 'length'); 101 | $am->distance($u, $v) 102 | 103 | my $am = Graph::AdjacencyMatrix->new($g, ...); 104 | my @V = $am->vertices(); 105 | 106 | $g = Graph->new(multiedged => 1); 107 | $g->add_...(); # build $g 108 | $am = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); 109 | $am->distance($u, $v) # returns hash-ref of ID => distance 110 | 111 | =head1 DESCRIPTION 112 | 113 | You can use C to compute the adjacency matrix 114 | and optionally also the distance matrix of a graph, and after that 115 | query the adjacencyness between vertices by using the C 116 | method, or query the distance between vertices by using the 117 | C method. 118 | 119 | By default the edge attribute used for distance is C, but you 120 | can change that in new(), see below. 121 | 122 | If you modify the graph after creating the adjacency matrix of it, 123 | the adjacency matrix and the distance matrix may become invalid. 124 | 125 | =head1 Methods 126 | 127 | =head2 Class Methods 128 | 129 | =over 4 130 | 131 | =item new($g) 132 | 133 | Construct the adjacency matrix of the graph $g. 134 | 135 | =item new($g, options) 136 | 137 | Construct the adjacency matrix of the graph $g with options as a hash. 138 | The known options are 139 | 140 | =over 8 141 | 142 | =item distance_matrix => boolean 143 | 144 | By default only the adjacency matrix is computed. To compute also the 145 | distance matrix, use the attribute C with a true value 146 | to the new() constructor. 147 | 148 | =item attribute_name => attribute_name 149 | 150 | By default the edge attribute used for distance is C. You can 151 | change that by giving another attribute name with the C 152 | attribute to new() constructor. Using this attribute also implicitly 153 | causes the distance matrix to be computed. 154 | 155 | =back 156 | 157 | =back 158 | 159 | =head2 Object Methods 160 | 161 | =over 4 162 | 163 | =item is_adjacent($u, $v) 164 | 165 | Return true if the vertex $v is adjacent to vertex $u, or false if not. 166 | 167 | =item distance($u, $v) 168 | 169 | Return the distance between the vertices $u and $v, or C if 170 | the vertices are not adjacent. 171 | 172 | If the underlying graph is multiedged, returns hash-ref of ID mapped 173 | to distance. If a given edge ID does not have the attribute defined, 174 | it will not be represented. If no edge IDs have the attribute, C 175 | will be returned. 176 | 177 | =item adjacency_matrix 178 | 179 | Return the adjacency matrix itself (a list of bitvector scalars). 180 | 181 | =item vertices 182 | 183 | Return the list of vertices (useful for indexing the adjacency matrix). 184 | 185 | =back 186 | 187 | =head1 ALGORITHM 188 | 189 | The algorithm used to create the matrix is two nested loops, which is 190 | O(V**2) in time, and the returned matrices are O(V**2) in space. 191 | 192 | =head1 SEE ALSO 193 | 194 | L, L 195 | 196 | =head1 AUTHOR AND COPYRIGHT 197 | 198 | Jarkko Hietaniemi F 199 | 200 | =head1 LICENSE 201 | 202 | This module is licensed under the same terms as Perl itself. 203 | 204 | =cut 205 | -------------------------------------------------------------------------------- /lib/Graph/Attribute.pm: -------------------------------------------------------------------------------- 1 | package Graph::Attribute; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my @API = qw(get_attribute 7 | get_attributes 8 | set_attribute 9 | set_attributes 10 | has_attribute 11 | has_attributes 12 | delete_attribute 13 | delete_attributes 14 | get_attribute_names 15 | get_attribute_values); 16 | 17 | sub import { 18 | my $package = shift; 19 | my %attr = @_; 20 | my $caller = caller(0); 21 | if (exists $attr{array}) { 22 | my $i = $attr{array}; 23 | no strict 'refs'; 24 | *{"${caller}::_g_get_attributes"} = sub { $_[0]->[ $i ] }; 25 | *{"${caller}::_g_set_attributes"} = 26 | sub { $_[0]->[ $i ] ||= { }; 27 | $_[0]->[ $i ] = $_[1] if @_ == 2; 28 | $_[0]->[ $i ] }; 29 | *{"${caller}::_g_has_attributes"} = sub { defined $_[0]->[ $i ] }; 30 | *{"${caller}::_g_delete_attributes"} = sub { undef $_[0]->[ $i ]; 1 }; 31 | } elsif (exists $attr{hash}) { 32 | my $k = $attr{hash}; 33 | no strict 'refs'; 34 | *{"${caller}::_g_get_attributes"} = sub { $_[0]->{ $k } }; 35 | *{"${caller}::_g_set_attributes"} = 36 | sub { $_[0]->{ $k } ||= { }; 37 | $_[0]->{ $k } = $_[1] if @_ == 2; 38 | $_[0]->{ $k } }; 39 | *{"${caller}::_g_has_attributes"} = sub { defined $_[0]->{ $k } }; 40 | *{"${caller}::_g_delete_attributes"} = sub { delete $_[0]->{ $k } }; 41 | } else { 42 | # uncoverable statement 43 | die "Graph::Attribute::import($package @_) caller $caller\n"; 44 | } 45 | if (exists $attr{map}) { 46 | my $map = $attr{map}; 47 | for my $api (@API) { 48 | my ($first, $rest) = ($api =~ /^(\w+?)_(.+)/); 49 | no strict 'refs'; 50 | *{"${caller}::${first}_${map}_${rest}"} = \&$api; 51 | } 52 | } 53 | } 54 | 55 | sub set_attribute { 56 | my $g = shift; 57 | my $v = pop; 58 | my $a = pop; 59 | my $p = $g->_g_set_attributes; 60 | $p->{ $a } = $v; 61 | return 1; 62 | } 63 | 64 | sub set_attributes { 65 | my $g = shift; 66 | my $a = pop; 67 | my $p = $g->_g_set_attributes( $a ); 68 | return 1; 69 | } 70 | 71 | sub has_attribute { 72 | my $g = shift; 73 | my $a = pop; 74 | my $p = $g->_g_get_attributes; 75 | $p ? exists $p->{ $a } : 0; 76 | } 77 | 78 | sub has_attributes { 79 | my $g = shift; 80 | $g->_g_get_attributes ? 1 : 0; 81 | } 82 | 83 | sub get_attribute { 84 | my $g = shift; 85 | my $a = pop; 86 | my $p = $g->_g_get_attributes; 87 | $p ? $p->{ $a } : undef; 88 | } 89 | 90 | sub delete_attribute { 91 | my $g = shift; 92 | my $a = pop; 93 | return 0 unless defined(my $p = $g->_g_get_attributes); 94 | delete $p->{ $a }; 95 | return 1; 96 | } 97 | 98 | sub delete_attributes { 99 | my $g = shift; 100 | return 0 if !$g->_g_has_attributes; 101 | $g->_g_delete_attributes; 102 | return 1; 103 | } 104 | 105 | sub get_attribute_names { 106 | my $g = shift; 107 | my $p = $g->_g_get_attributes; 108 | defined $p ? keys %{ $p } : ( ); 109 | } 110 | 111 | sub get_attribute_values { 112 | my $g = shift; 113 | my $p = $g->_g_get_attributes; 114 | defined $p ? values %{ $p } : ( ); 115 | } 116 | 117 | sub get_attributes { 118 | $_[0]->_g_get_attributes; 119 | } 120 | 121 | 1; 122 | -------------------------------------------------------------------------------- /lib/Graph/BitMatrix.pm: -------------------------------------------------------------------------------- 1 | package Graph::BitMatrix; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # $SIG{__DIE__ } = \&Graph::__carp_confess; 7 | # $SIG{__WARN__} = \&Graph::__carp_confess; 8 | 9 | sub _E () { 3 } # Graph::_E() 10 | sub _i () { 3 } # Index to path. 11 | 12 | sub new { 13 | my ($class, $g, %opt) = @_; 14 | my @V = $g->vertices; 15 | my $V = @V; 16 | my $Z = "\0" x (($V + 7) / 8); 17 | my %V; @V{ @V } = 0 .. $#V; 18 | my $bm = bless [ [ ( $Z ) x $V ], \%V ], $class; 19 | my $bm0 = $bm->[0]; 20 | my $connect_edges = delete $opt{connect_edges}; 21 | $connect_edges = 1 unless defined $connect_edges; 22 | my $transpose = delete $opt{transpose}; 23 | Graph::_opt_unknown(\%opt); 24 | return $bm if !$connect_edges; 25 | # for (my $i = 0; $i <= $#V; $i++) { 26 | # my $u = $V[$i]; 27 | # for (my $j = 0; $j <= $#V; $j++) { 28 | # vec($bm0->[$i], $j, 1) = 1 if $g->has_edge($u, $V[$j]); 29 | # } 30 | # } 31 | my $undirected = $g->is_undirected; 32 | for my $e ($g->edges) { 33 | my ($i0, $j0) = map $V{$_}, @$e; 34 | ($j0, $i0) = ($i0, $j0) if $transpose; 35 | vec($bm0->[$i0], $j0, 1) = 1; 36 | vec($bm0->[$j0], $i0, 1) = 1 if $undirected; 37 | } 38 | $bm; 39 | } 40 | 41 | sub stringify { 42 | my ($m) = @_; 43 | my @V = sort keys %{ $m->[1] }; 44 | my $top = join ' ', map sprintf('%4s', $_), 'to:', @V; 45 | my @indices = map $m->[1]{$_}, @V; 46 | my @rows; 47 | for my $n (@V) { 48 | my @vals = $m->get_row($n, @V); 49 | push @rows, join ' ', map sprintf('%4s', defined()?$_:''), $n, @vals; 50 | } 51 | join '', map "$_\n", $top, @rows; 52 | } 53 | 54 | sub set { push @_, 1; goto &_get_set } 55 | sub unset { push @_, 0; goto &_get_set } 56 | sub get { push @_, undef; goto &_get_set } 57 | sub _get_set { 58 | my $val = pop; 59 | my ($m, $u, $v) = @_; 60 | my ($m0, $m1) = @$m[0, 1]; 61 | return if grep !defined, my ($i, $j) = @$m1{ $u, $v }; 62 | defined $val ? vec($m0->[$i], $j, 1) = $val : vec($m0->[$i], $j, 1); 63 | } 64 | 65 | sub _set_row { 66 | my $val = pop; 67 | my ($m, $u) = splice @_, 0, 2; 68 | my ($m0, $m1) = @$m[0, 1]; 69 | return unless defined(my $i = $m1->{ $u }); 70 | vec($m0->[$i], $_, 1) = $val for grep defined, @$m1{ @_ }; 71 | } 72 | sub set_row { push @_, 1; goto &_set_row } 73 | sub unset_row { push @_, 0; goto &_set_row } 74 | 75 | sub get_row { 76 | my ($m, $u) = splice @_, 0, 2; 77 | my ($m0, $m1) = @$m[0, 1]; 78 | return () x @_ unless defined(my $i = $m1->{ $u }); 79 | map defined() ? (vec($m0->[$i], $_, 1) ? 1 : 0) : undef, @$m1{ @_ }; 80 | } 81 | 82 | sub vertices { 83 | keys %{ $_[0]->[1] }; 84 | } 85 | 86 | 1; 87 | __END__ 88 | =pod 89 | 90 | =head1 NAME 91 | 92 | Graph::BitMatrix - create and manipulate a V x V bit matrix of graph G 93 | 94 | =head1 SYNOPSIS 95 | 96 | use Graph::BitMatrix; 97 | use Graph::Directed; 98 | my $g = Graph::Directed->new; 99 | $g->add_...(); # build $g 100 | my $m = Graph::BitMatrix->new($g, %opt); 101 | $m->get($u, $v) 102 | $m->set($u, $v) 103 | $m->unset($u, $v) 104 | $m->get_row($u, $v1, $v2, ..., $vn) 105 | $m->set_row($u, $v1, $v2, ..., $vn) 106 | $m->unset_row($u, $v1, $v2, ..., $vn) 107 | $a->vertices() 108 | 109 | =head1 DESCRIPTION 110 | 111 | This class enables creating bit matrices that compactly describe 112 | the connected of the graphs. 113 | 114 | =head2 Class Methods 115 | 116 | =over 4 117 | 118 | =item new($g) 119 | 120 | Create a bit matrix from a Graph $g. The C<%opt>, if present, 121 | can have the following options: 122 | 123 | =over 8 124 | 125 | =item * 126 | 127 | connect_edges 128 | 129 | If true or if not present, set the bits in the bit matrix that 130 | correspond to edges. If false, do not set any bits. In either 131 | case the bit matrix of V x V bits is allocated. 132 | 133 | =item * 134 | 135 | transpose 136 | 137 | If true, set the bits in the bit matrix that correspond to edges 138 | but in the reverse direction. This has the effect of transposing the 139 | matrix. Obviously makes no difference to the result for undirected graphs. 140 | 141 | =back 142 | 143 | =back 144 | 145 | =head2 Object Methods 146 | 147 | =over 4 148 | 149 | =item get($u, $v) 150 | 151 | Return true if the bit matrix has a "one bit" between the vertices 152 | $u and $v; in other words, if there is (at least one) a vertex going from 153 | $u to $v. If there is no vertex and therefore a "zero bit", return false. 154 | 155 | =item set($u, $v) 156 | 157 | Set the bit between the vertices $u and $v; in other words, connect 158 | the vertices $u and $v by an edge. The change does not get mirrored 159 | back to the original graph. Returns nothing. 160 | 161 | =item unset($u, $v) 162 | 163 | Unset the bit between the vertices $u and $v; in other words, disconnect 164 | the vertices $u and $v by an edge. The change does not get mirrored 165 | back to the original graph. Returns nothing. 166 | 167 | =item get_row($u, $v1, $v2, ..., $vn) 168 | 169 | Test the row at vertex C for the vertices C, C, ..., C 170 | Returns a list of I truth values. 171 | 172 | =item set_row($u, $v1, $v2, ..., $vn) 173 | 174 | Sets the row at vertex C for the vertices C, C, ..., C, 175 | in other words, connects the vertex C to the vertices C. 176 | The changes do not get mirrored back to the original graph. 177 | Returns nothing. 178 | 179 | =item unset_row($u, $v1, $v2, ..., $vn) 180 | 181 | Unsets the row at vertex C for the vertices C, C, ..., C, 182 | in other words, disconnects the vertex C from the vertices C. 183 | The changes do not get mirrored back to the original graph. 184 | Returns nothing. 185 | 186 | =item vertices 187 | 188 | Return the list of vertices in the bit matrix. 189 | 190 | =back 191 | 192 | =head1 ALGORITHM 193 | 194 | The algorithm used to create the matrix is two nested loops, which is 195 | O(V**2) in time, and the returned matrices are O(V**2) in space. 196 | 197 | =head1 AUTHOR AND COPYRIGHT 198 | 199 | Jarkko Hietaniemi F 200 | 201 | =head1 LICENSE 202 | 203 | This module is licensed under the same terms as Perl itself. 204 | 205 | =cut 206 | -------------------------------------------------------------------------------- /lib/Graph/Directed.pm: -------------------------------------------------------------------------------- 1 | package Graph::Directed; 2 | 3 | use Graph; 4 | use base 'Graph'; 5 | use strict; 6 | use warnings; 7 | 8 | =pod 9 | 10 | =head1 NAME 11 | 12 | Graph::Directed - directed graphs 13 | 14 | =head1 SYNOPSIS 15 | 16 | use Graph::Directed; 17 | my $g = Graph::Directed->new; 18 | 19 | # Or alternatively: 20 | 21 | use Graph; 22 | my $g = Graph->new(directed => 1); 23 | my $g = Graph->new(undirected => 0); 24 | 25 | =head1 DESCRIPTION 26 | 27 | Graph::Directed allows you to create directed graphs. 28 | 29 | For the available methods, see L. 30 | 31 | =head1 SEE ALSO 32 | 33 | L, L 34 | 35 | =head1 AUTHOR AND COPYRIGHT 36 | 37 | Jarkko Hietaniemi F 38 | 39 | =head1 LICENSE 40 | 41 | This module is licensed under the same terms as Perl itself. 42 | 43 | =cut 44 | 45 | 1; 46 | -------------------------------------------------------------------------------- /lib/Graph/MSTHeapElem.pm: -------------------------------------------------------------------------------- 1 | package Graph::MSTHeapElem; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | bless { u => $_[0], v => $_[1], w => $_[2] }, $class; 9 | } 10 | 11 | sub heap { 12 | my $self = shift; 13 | @_ ? ($self->{heap} = shift) : $self->{heap}; 14 | } 15 | 16 | sub cmp { 17 | ($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0); 18 | } 19 | 20 | sub val { 21 | @{ $_[0] }{ qw(u v w) }; 22 | } 23 | 24 | 1; 25 | -------------------------------------------------------------------------------- /lib/Graph/Matrix.pm: -------------------------------------------------------------------------------- 1 | package Graph::Matrix; 2 | 3 | # $SIG{__DIE__ } = \&Graph::__carp_confess; 4 | # $SIG{__WARN__} = \&Graph::__carp_confess; 5 | 6 | use strict; 7 | use warnings; 8 | 9 | sub new { 10 | my ($class, $g) = @_; 11 | my @V = $g->vertices; 12 | my $V = @V; 13 | my %V; @V{ @V } = 0 .. $#V; 14 | bless [ [ map [], 0 .. $#V ], \%V ], $class; 15 | } 16 | 17 | sub set { 18 | my ($m, $u, $v, $val) = @_; 19 | my ($i, $j) = map $m->[1]->{ $_ }, ($u, $v); 20 | $m->[0]->[$i]->[$j] = $val; 21 | } 22 | 23 | sub get { 24 | my ($m, $u, $v) = @_; 25 | my ($i, $j) = map $m->[1]->{ $_ }, ($u, $v); 26 | $m->[0]->[$i]->[$j]; 27 | } 28 | 29 | sub stringify { 30 | my ($m) = @_; 31 | my @V = sort keys %{ $m->[1] }; 32 | my $top = join ' ', map sprintf('%4s', $_), 'to:', @V; 33 | my @indices = map $m->[1]{$_}, @V; 34 | my @rows; 35 | for my $n (@V) { 36 | my $this_row = $m->[0][ $m->[1]->{$n} ]; 37 | my @vals = map $this_row->[ $_ ], @indices; 38 | push @rows, join ' ', map sprintf('%4s', defined()?$_:''), $n, @vals; 39 | } 40 | join '', map "$_\n", $top, @rows; 41 | } 42 | 43 | 1; 44 | __END__ 45 | =pod 46 | 47 | =head1 NAME 48 | 49 | Graph::Matrix - create and manipulate a V x V matrix of graph G 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Graph::Matrix; 54 | use Graph::Directed; 55 | my $g = Graph::Directed->new; 56 | $g->add_...(); # build $g 57 | my $m = Graph::Matrix->new($g); 58 | $m->get($u, $v) 59 | $s->get($u, $v, $val) 60 | 61 | =head1 DESCRIPTION 62 | 63 | B 64 | 65 | =head2 Class Methods 66 | 67 | =over 4 68 | 69 | =item new($g) 70 | 71 | Construct a new Matrix from the Graph $g. 72 | 73 | =back 74 | 75 | =head2 Object Methods 76 | 77 | =over 4 78 | 79 | =item get($u, $v) 80 | 81 | Return the value at the edge from $u to $v. 82 | 83 | =item set($u, $v, $val) 84 | 85 | Set the edge from $u to $v to value $val. 86 | 87 | =item stringify 88 | 89 | Returns a string roughly representing the matrix, with the C<$u> down 90 | the left-hand side, and C<$v> across the top. 91 | 92 | =back 93 | 94 | =head1 AUTHOR AND COPYRIGHT 95 | 96 | Jarkko Hietaniemi F 97 | 98 | =head1 LICENSE 99 | 100 | This module is licensed under the same terms as Perl itself. 101 | 102 | =cut 103 | -------------------------------------------------------------------------------- /lib/Graph/SPTHeapElem.pm: -------------------------------------------------------------------------------- 1 | package Graph::SPTHeapElem; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | bless { u => $_[0], v => $_[1], w => $_[2] }, $class; 9 | } 10 | 11 | sub heap { 12 | my $self = shift; 13 | @_ ? ($self->{heap} = shift) : $self->{heap}; 14 | } 15 | 16 | sub cmp { 17 | ($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0) || 18 | ($_[0]->{ u } cmp $_[1]->{ u }) || 19 | ($_[0]->{ u } cmp $_[1]->{ v }); 20 | } 21 | 22 | sub val { 23 | @{ $_[0] }{ qw(u v w) }; 24 | } 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /lib/Graph/TransitiveClosure.pm: -------------------------------------------------------------------------------- 1 | package Graph::TransitiveClosure; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # COMMENT THESE OUT FOR TESTING AND PRODUCTION. 7 | # $SIG{__DIE__ } = \&Graph::__carp_confess; 8 | # $SIG{__WARN__} = \&Graph::__carp_confess; 9 | 10 | use base 'Graph'; 11 | use Graph::TransitiveClosure::Matrix; 12 | 13 | sub _G () { Graph::_G() } 14 | 15 | sub new { 16 | my ($class, $g, %opt) = @_; 17 | Graph::__carp_confess(__PACKAGE__."->new given non-Graph '$g'") 18 | if !(ref $g and $g->isa('Graph')); 19 | %opt = (path_vertices => 1) unless %opt; 20 | # No delete $opt{ attribute_name } since we need to pass it on. 21 | my $attr = exists $opt{ attribute_name } ? $opt{ attribute_name } : Graph::_defattr(); 22 | $opt{ reflexive } = 1 unless exists $opt{ reflexive }; 23 | my $tcg = $g->new( 24 | multiedged => 0, 25 | ($opt{ reflexive } ? (vertices => [$g->vertices]) : ()), 26 | ); 27 | my $tcm = $g->_check_cache('transitive_closure_matrix', [], 28 | \&_transitive_closure_matrix_compute, %opt); 29 | my $tcm00 = $tcm->[0][0]; # 0=am, 0=bitmatrix 30 | my $tcm01 = $tcm->[0][1]; # , 1=hash mapping v-name to the offset into dm data structures (in retval of $g->vertices) 31 | my @edges; 32 | for my $u ($tcm->vertices) { 33 | my $tcm00i = $tcm00->[ $tcm01->{ $u } ]; 34 | for my $v ($tcm->vertices) { 35 | next if $u eq $v && ! $opt{ reflexive }; 36 | my $j = $tcm01->{ $v }; 37 | push @edges, [$u, $v] if vec($tcm00i, $j, 1); 38 | # $tcm->is_transitive($u, $v) 39 | # $tcm->[0]->get($u, $v) 40 | } 41 | } 42 | $tcg->add_edges(@edges); 43 | $tcg->set_graph_attribute('_tcm', [ $g->[ _G ], $tcm ]); 44 | bless $tcg, $class; 45 | } 46 | 47 | sub _transitive_closure_matrix_compute { 48 | Graph::TransitiveClosure::Matrix->new(@_); 49 | } 50 | 51 | sub is_transitive { 52 | my $g = shift; 53 | $g->expect_no_args(@_); 54 | Graph::TransitiveClosure::Matrix::is_transitive($g); 55 | } 56 | 57 | sub transitive_closure_matrix { 58 | $_[0]->get_graph_attribute('_tcm')->[1]; 59 | } 60 | 61 | 1; 62 | __END__ 63 | =pod 64 | 65 | =head1 NAME 66 | 67 | Graph::TransitiveClosure - create and query transitive closure of graph 68 | 69 | =head1 SYNOPSIS 70 | 71 | use Graph::TransitiveClosure; 72 | use Graph::Directed; # or Undirected 73 | 74 | my $g = Graph::Directed->new; 75 | $g->add_...(); # build $g 76 | 77 | # Compute the transitive closure graph. 78 | my $tcg = Graph::TransitiveClosure->new($g); 79 | $tcg->is_reachable($u, $v) # Identical to $tcg->has_edge($u, $v) 80 | 81 | # Being reflexive is the default, meaning that null transitions 82 | # (transitions from a vertex to the same vertex) are included. 83 | my $tcg = Graph::TransitiveClosure->new($g, reflexive => 1); 84 | my $tcg = Graph::TransitiveClosure->new($g, reflexive => 0); 85 | 86 | # is_reachable(u, v) is always reflexive. 87 | $tcg->is_reachable($u, $v) 88 | 89 | # You can check any graph for transitivity. 90 | $g->is_transitive() 91 | 92 | my $tcg = Graph::TransitiveClosure->new($g, path_length => 1); 93 | $tcg->path_length($u, $v) 94 | 95 | # path_vertices is on by default so this is a no-op. 96 | my $tcg = Graph::TransitiveClosure->new($g, path_vertices => 1); 97 | $tcg->path_vertices($u, $v) 98 | 99 | # see how many paths exist from $u to $v 100 | my $tcg = Graph::TransitiveClosure->new($g, path_count => 1); 101 | $tcg->path_length($u, $v) 102 | 103 | # Both path_length and path_vertices. 104 | my $tcg = Graph::TransitiveClosure->new($g, path => 1); 105 | $tcg->path_vertices($u, $v) 106 | $tcg->length($u, $v) 107 | 108 | my $tcg = Graph::TransitiveClosure->new($g, attribute_name => 'length'); 109 | $tcg->path_length($u, $v) 110 | 111 | =head1 DESCRIPTION 112 | 113 | You can use C to compute the transitive 114 | closure graph of a graph and optionally also the minimum paths 115 | (lengths and vertices) between vertices, and after that query the 116 | transitiveness between vertices by using the C and 117 | C methods, and the paths by using the 118 | C and C methods. 119 | 120 | For further documentation, see the L. 121 | 122 | =head2 Class Methods 123 | 124 | =over 4 125 | 126 | =item new($g, %opt) 127 | 128 | Construct a new transitive closure object. Note that strictly speaking 129 | the returned object is not a graph; it is a graph plus other stuff. But 130 | you should be able to use it as a graph plus a couple of methods inherited 131 | from the Graph::TransitiveClosure::Matrix class. 132 | 133 | =back 134 | 135 | =head2 Object Methods 136 | 137 | These are only the methods 'native' to the class: see 138 | L for more. 139 | 140 | =over 4 141 | 142 | =item is_transitive($g) 143 | 144 | Return true if the Graph $g is transitive. 145 | 146 | =item transitive_closure_matrix 147 | 148 | Return the transitive closure matrix of the transitive closure object. 149 | 150 | =back 151 | 152 | =cut 153 | -------------------------------------------------------------------------------- /lib/Graph/Traversal/BFS.pm: -------------------------------------------------------------------------------- 1 | package Graph::Traversal::BFS; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Graph::Traversal; 7 | use base 'Graph::Traversal'; 8 | 9 | sub current { 10 | my $self = shift; 11 | $self->{ order }->[ 0 ]; 12 | } 13 | 14 | sub see { 15 | my $self = shift; 16 | shift @{ $self->{ order } }; 17 | } 18 | 19 | *bfs = \&Graph::Traversal::postorder; 20 | 21 | 1; 22 | __END__ 23 | =pod 24 | 25 | =head1 NAME 26 | 27 | Graph::Traversal::BFS - breadth-first traversal of graphs 28 | 29 | =head1 SYNOPSIS 30 | 31 | use Graph; 32 | my $g = Graph->new; 33 | $g->add_edge(...); 34 | use Graph::Traversal::BFS; 35 | my $b = Graph::Traversal::BFS->new($g, %opt); 36 | $b->bfs; # Do the traversal. 37 | 38 | =head1 DESCRIPTION 39 | 40 | With this class one can traverse a Graph in breadth-first order. 41 | 42 | The callback parameters %opt are explained in L. 43 | 44 | =head2 Methods 45 | 46 | The following methods are available: 47 | 48 | =over 4 49 | 50 | =item bfs 51 | 52 | Traverse the graph in breadth-first order. Returns all vertices 53 | traversed in post-order. 54 | 55 | =back 56 | 57 | =head1 SEE ALSO 58 | 59 | L, L, L. 60 | 61 | =cut 62 | -------------------------------------------------------------------------------- /lib/Graph/Traversal/DFS.pm: -------------------------------------------------------------------------------- 1 | package Graph::Traversal::DFS; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Graph::Traversal; 7 | use base 'Graph::Traversal'; 8 | 9 | sub current { 10 | my $self = shift; 11 | $self->{ order }->[ -1 ]; 12 | } 13 | 14 | sub see { 15 | my $self = shift; 16 | pop @{ $self->{ order } }; 17 | } 18 | 19 | *dfs = \&Graph::Traversal::postorder; 20 | 21 | 1; 22 | __END__ 23 | =pod 24 | 25 | =head1 NAME 26 | 27 | Graph::Traversal::DFS - depth-first traversal of graphs 28 | 29 | =head1 SYNOPSIS 30 | 31 | use Graph; 32 | my $g = Graph->new; 33 | $g->add_edge(...); 34 | use Graph::Traversal::DFS; 35 | my $d = Graph::Traversal::DFS->new($g, %opt); 36 | $d->dfs; # Do the traversal. 37 | 38 | =head1 DESCRIPTION 39 | 40 | With this class one can traverse a Graph in depth-first order. 41 | 42 | The callback parameters %opt are explained in L. 43 | 44 | =head2 Methods 45 | 46 | The following methods are available: 47 | 48 | =over 4 49 | 50 | =item dfs 51 | 52 | Traverse the graph in depth-first order. Returns all vertices 53 | traversed in post-order. 54 | 55 | =back 56 | 57 | =head1 SEE ALSO 58 | 59 | L, L, L. 60 | 61 | =cut 62 | -------------------------------------------------------------------------------- /lib/Graph/Undirected.pm: -------------------------------------------------------------------------------- 1 | package Graph::Undirected; 2 | 3 | use Graph; 4 | use base 'Graph'; 5 | use strict; 6 | use warnings; 7 | 8 | =pod 9 | 10 | =head1 NAME 11 | 12 | Graph::Undirected - undirected graphs 13 | 14 | =head1 SYNOPSIS 15 | 16 | use Graph::Undirected; 17 | my $g = Graph::Undirected->new; 18 | 19 | # Or alternatively: 20 | 21 | use Graph; 22 | my $g = Graph->new(undirected => 1); 23 | my $g = Graph->new(directed => 0); 24 | 25 | =head1 DESCRIPTION 26 | 27 | Graph::Undirected allows you to create undirected graphs. 28 | 29 | For the available methods, see L. 30 | 31 | =head1 SEE ALSO 32 | 33 | L, L 34 | 35 | =head1 AUTHOR AND COPYRIGHT 36 | 37 | Jarkko Hietaniemi F 38 | 39 | =head1 LICENSE 40 | 41 | This module is licensed under the same terms as Perl itself. 42 | 43 | =cut 44 | 45 | sub new { 46 | my $class = shift; 47 | $class->SUPER::new((ref $class && $class->directed) ? () : (undirected => 1), @_); 48 | } 49 | 50 | 1; 51 | -------------------------------------------------------------------------------- /lib/Graph/UnionFind.pm: -------------------------------------------------------------------------------- 1 | package Graph::UnionFind; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub _PARENT () { 0 } 7 | sub _RANK () { 1 } 8 | 9 | sub new { 10 | my $class = shift; 11 | bless { }, $class; 12 | } 13 | 14 | sub add { 15 | my ($self, @elems) = @_; 16 | @elems = grep !defined $self->{$_}, @elems; 17 | @$self{ @elems } = map [ $_, 0 ], @elems; 18 | } 19 | 20 | sub _parent { 21 | return undef unless defined $_[1]; 22 | Graph::__carp_confess(__PACKAGE__ . "::_parent: bad arity") if @_ < 2 or @_ > 3; 23 | if (@_ == 2) { 24 | exists $_[0]->{ $_[ 1 ] } ? $_[0]->{ $_[1] }->[ _PARENT ] : undef; 25 | } else { 26 | $_[0]->{ $_[1] }->[ _PARENT ] = $_[2]; 27 | } 28 | } 29 | 30 | sub _rank { 31 | return unless defined $_[1]; 32 | Graph::__carp_confess(__PACKAGE__ . "::_rank: bad arity") if @_ < 2 or @_ > 3; 33 | if (@_ == 2) { 34 | exists $_[0]->{ $_[1] } ? $_[0]->{ $_[1] }->[ _RANK ] : undef; 35 | } else { 36 | $_[0]->{ $_[1] }->[ _RANK ] = $_[2]; 37 | } 38 | } 39 | 40 | sub find { 41 | my ($self, @v) = @_; 42 | my @ret; 43 | for my $x (@v) { 44 | push(@ret, undef), next unless defined(my $px = $self->_parent($x)); 45 | $self->_parent( $x, $self->find( $px ) ) if $px ne $x; 46 | push @ret, $self->_parent( $x ); 47 | } 48 | @ret; 49 | } 50 | 51 | sub union { 52 | my ($self, @edges) = @_; 53 | $self->add(map @$_, @edges); 54 | for my $e (@edges) { 55 | my ($px, $py) = $self->find( @$e ); 56 | next if $px eq $py; 57 | my $rx = $self->_rank( $px ); 58 | my $ry = $self->_rank( $py ); 59 | # print "union($x, $y): px = $px, py = $py, rx = $rx, ry = $ry\n"; 60 | if ( $rx > $ry ) { 61 | $self->_parent( $py, $px ); 62 | } else { 63 | $self->_parent( $px, $py ); 64 | $self->_rank( $py, $ry + 1 ) if $rx == $ry; 65 | } 66 | } 67 | } 68 | 69 | sub same { 70 | my ($uf, $u, $v) = @_; 71 | my ($fu, $fv) = $uf->find($u, $v); 72 | return undef if grep !defined, $fu, $fv; 73 | $fu eq $fv; 74 | } 75 | 76 | 1; 77 | __END__ 78 | =pod 79 | 80 | =head1 NAME 81 | 82 | Graph::UnionFind - union-find data structures 83 | 84 | =head1 SYNOPSIS 85 | 86 | use Graph::UnionFind; 87 | my $uf = Graph::UnionFind->new; 88 | 89 | # Add the vertices to the data structure. 90 | $uf->add($u); 91 | $uf->add($v); 92 | 93 | # Join the partitions of the vertices. 94 | $uf->union( $u, $v ); 95 | 96 | # Find the partitions the vertices belong to 97 | # in the union-find data structure. If they 98 | # are equal, they are in the same partition. 99 | # If the vertex has not been seen, 100 | # undef is returned. 101 | my $pu = $uf->find( $u ); 102 | my $pv = $uf->find( $v ); 103 | $uf->same($u, $v) # Equal to $pu eq $pv. 104 | 105 | # Has the union-find seen this vertex? 106 | $uf->has( $v ) 107 | 108 | =head1 DESCRIPTION 109 | 110 | I is a special data structure that can be used to track the 111 | partitioning of a set into subsets (a problem also known as I). 112 | 113 | C is used for L, 114 | L, and L 115 | if you specify a true C parameter when you create an undirected 116 | graph. 117 | 118 | Union-find is one way: you cannot (easily) 'ununion' vertices once you 119 | have 'unioned' them. This is why L throws an exception if you 120 | try to delete edges from a union-find graph. 121 | 122 | =head2 API 123 | 124 | =over 4 125 | 126 | =item add 127 | 128 | $uf->add(@v) 129 | 130 | Add the vertices to the union-find. 131 | 132 | =item union 133 | 134 | $uf->union([$u, $v], [$w, $x], ...) 135 | 136 | Add the edge u-v to the union-find. Also implicitly adds the vertices. 137 | 138 | =item find 139 | 140 | @partitions = $uf->find(@v) 141 | 142 | For each given vertex, return the union-find partition it belongs to, 143 | or C if it has not been added. 144 | 145 | =item new 146 | 147 | $uf = Graph::UnionFind->new() 148 | 149 | The constructor. 150 | 151 | =item same 152 | 153 | $uf->same($u, $v) 154 | 155 | Return true of the vertices belong to the same union-find partition 156 | the vertex v belongs to, false otherwise. 157 | 158 | =back 159 | 160 | =head1 AUTHOR AND COPYRIGHT 161 | 162 | Jarkko Hietaniemi F 163 | 164 | =head1 LICENSE 165 | 166 | This module is licensed under the same terms as Perl itself. 167 | 168 | =cut 169 | 170 | -------------------------------------------------------------------------------- /t/00-report-prereqs.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.020 7 | # THEN modified with more info by Ed J for PDL project 8 | 9 | use Test::More tests => 1; 10 | 11 | use ExtUtils::MakeMaker; 12 | use File::Spec; 13 | 14 | # from $version::LAX 15 | my $lax_version_re = 16 | qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? 17 | | 18 | (?:\.[0-9]+) (?:_[0-9]+)? 19 | ) | (?: 20 | v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? 21 | | 22 | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? 23 | ) 24 | )/x; 25 | 26 | # hide optional CPAN::Meta modules from prereq scanner 27 | # and check if they are available 28 | my $cpan_meta = "CPAN::Meta"; 29 | my $cpan_meta_pre = "CPAN::Meta::Prereqs"; 30 | my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic 31 | 32 | # Verify requirements? 33 | my $DO_VERIFY_PREREQS = 1; 34 | 35 | sub _max { 36 | my $max = shift; 37 | $max = ( $_ > $max ) ? $_ : $max for @_; 38 | return $max; 39 | } 40 | 41 | sub _merge_prereqs { 42 | my ($collector, $prereqs) = @_; 43 | 44 | # CPAN::Meta::Prereqs object 45 | if (ref $collector eq $cpan_meta_pre) { 46 | return $collector->with_merged_prereqs( 47 | CPAN::Meta::Prereqs->new( $prereqs ) 48 | ); 49 | } 50 | 51 | # Raw hashrefs 52 | for my $phase ( keys %$prereqs ) { 53 | for my $type ( keys %{ $prereqs->{$phase} } ) { 54 | for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { 55 | $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; 56 | } 57 | } 58 | } 59 | 60 | return $collector; 61 | } 62 | 63 | my @include = qw( 64 | 65 | ); 66 | 67 | my @exclude = qw( 68 | 69 | ); 70 | 71 | # Add static prereqs to the included modules list 72 | my $static_prereqs = do 't/00-report-prereqs.dd'; 73 | 74 | # Merge all prereqs (either with ::Prereqs or a hashref) 75 | my $full_prereqs = _merge_prereqs( 76 | ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), 77 | $static_prereqs 78 | ); 79 | 80 | # Add dynamic prereqs to the included modules list (if we can) 81 | my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; 82 | if ( $source && $HAS_CPAN_META ) { 83 | if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { 84 | $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); 85 | } 86 | } 87 | else { 88 | $source = 'static metadata'; 89 | } 90 | 91 | my @full_reports; 92 | my @dep_errors; 93 | my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; 94 | 95 | # Add static includes into a fake section 96 | for my $mod (@include) { 97 | $req_hash->{other}{modules}{$mod} = 0; 98 | } 99 | 100 | for my $phase ( qw(configure build test runtime develop other) ) { 101 | next unless $req_hash->{$phase}; 102 | next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); 103 | 104 | for my $type ( qw(requires recommends suggests conflicts modules) ) { 105 | next unless $req_hash->{$phase}{$type}; 106 | 107 | my $title = ucfirst($phase).' '.ucfirst($type); 108 | my @reports = [qw/Module Want Have Where Howbig/]; 109 | 110 | for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { 111 | next if $mod eq 'perl'; 112 | next if grep { $_ eq $mod } @exclude; 113 | 114 | my $file = $mod; 115 | $file =~ s{::}{/}g; 116 | $file .= ".pm"; 117 | my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; 118 | 119 | my $want = $req_hash->{$phase}{$type}{$mod}; 120 | $want = "undef" unless defined $want; 121 | $want = "any" if !$want && $want == 0; 122 | 123 | my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; 124 | 125 | if ($prefix) { 126 | my $filename = File::Spec->catfile($prefix, $file); 127 | my $have = MM->parse_version( $filename ); 128 | $have = "undef" unless defined $have; 129 | push @reports, [$mod, $want, $have, $prefix, (-s $filename)]; 130 | 131 | if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { 132 | if ( $have !~ /\A$lax_version_re\z/ ) { 133 | push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; 134 | } 135 | elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { 136 | push @dep_errors, "$mod version '$have' is not in required range '$want'"; 137 | } 138 | } 139 | } 140 | else { 141 | push @reports, [$mod, $want, "missing", '', 0]; 142 | 143 | if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { 144 | push @dep_errors, "$mod is not installed ($req_string)"; 145 | } 146 | } 147 | } 148 | 149 | if ( @reports ) { 150 | push @full_reports, "=== $title ===\n\n"; 151 | 152 | my $ml = _max( map { length $_->[0] } @reports ); 153 | my $wl = _max( map { length $_->[1] } @reports ); 154 | my $hl = _max( map { length $_->[2] } @reports ); 155 | my $ll = _max( map { length $_->[3] } @reports ); # location 156 | my $sl = _max( map { length $_->[4] } @reports ); # size 157 | 158 | if ($type eq 'modules') { 159 | splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl, "-" x $ll, "-" x $sl]; 160 | push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; 161 | } 162 | else { 163 | splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl, "-" x $ll, "-" x $sl]; 164 | push @full_reports, map { sprintf(" %*s %*s %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2], -$ll, $_->[3], $sl, $_->[4]) } @reports; 165 | } 166 | 167 | push @full_reports, "\n"; 168 | } 169 | } 170 | } 171 | 172 | if ( @full_reports ) { 173 | diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; 174 | } 175 | 176 | if ( @dep_errors ) { 177 | diag join("\n", 178 | "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", 179 | "The following REQUIRED prerequisites were not satisfied:\n", 180 | @dep_errors, 181 | "\n" 182 | ); 183 | } 184 | 185 | pass; 186 | 187 | # vim: ts=4 sts=4 sw=4 et: 188 | -------------------------------------------------------------------------------- /t/00_use.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 1; 3 | 4 | use_ok('Graph'); 5 | -------------------------------------------------------------------------------- /t/01_isa.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 2; 3 | 4 | use Graph; 5 | 6 | my $g = Graph->new; 7 | 8 | isa_ok($g, 'Graph'); 9 | 10 | my $h = $g->new; 11 | 12 | isa_ok($g, 'Graph'); 13 | -------------------------------------------------------------------------------- /t/02_trap.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 2; 3 | 4 | use Graph; 5 | 6 | isnt($SIG{__DIE__}, \&Graph::__carp_confess, '$SIG{__DIE__}' ); 7 | isnt($SIG{__WARN__}, \&Graph::__carp_confess, '$SIG{__WARN__}'); 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /t/03_derived.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 4; 3 | 4 | use lib 't'; 5 | use MyGraph; 6 | 7 | my $g = MyGraph->new; 8 | 9 | isa_ok($g, 'MyGraph'); 10 | isa_ok($g, 'Graph'); 11 | 12 | my $h = $g->new; 13 | 14 | isa_ok($h, 'MyGraph'); 15 | isa_ok($h, 'Graph'); 16 | 17 | -------------------------------------------------------------------------------- /t/04_dgraph.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 1; 3 | 4 | use lib 't'; 5 | use MyDGraph; 6 | 7 | # http://rt.cpan.org/NoAuth/Bug.html?id=6429 8 | ok(ref(new DGraph), "DGraph"); 9 | -------------------------------------------------------------------------------- /t/05_ugraph.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 1; 3 | 4 | use lib 't'; 5 | use MyUGraph; 6 | 7 | # http://rt.cpan.org/NoAuth/Bug.html?id=6429 8 | ok(ref(new UGraph), "UGraph"); 9 | -------------------------------------------------------------------------------- /t/06_new.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph; 5 | 6 | for my $c (qw(Graph Graph::Directed Graph::Undirected)) { 7 | test_prop($c, @$_) for ( 8 | # 2nd is whether default is true, then opposites 9 | [refvertexed => 0, []], 10 | [countvertexed => 0, []], 11 | [multivertexed => 0, []], 12 | [undirected => $c eq 'Graph::Undirected', [qw(directed)]], 13 | [directed => $c ne 'Graph::Undirected', [qw(undirected)]], 14 | [countedged => 0, []], 15 | [multiedged => 0, []], 16 | [hyperedged => 0, []], 17 | ); 18 | } 19 | 20 | sub test_prop { 21 | my ($class, $prop, $true_by_default, $opposites) = @_; 22 | my $g = $class->new; 23 | my $got = $g->$prop; 24 | $got = !$got if !$true_by_default; 25 | ok $got, "$prop correct default value"; 26 | $g = $class->new( $prop => 0 ); 27 | ok !$g->$prop, "$prop reflects given false value"; 28 | ok !$g->new->$prop, "$prop survives $class->new with false value"; 29 | ok $g->$_, "$prop opposite=$_ right" for @$opposites; 30 | $g = $class->new( $prop => 1 ); 31 | ok $g->$prop, "$prop reflects given true value"; 32 | ok $g->new->$prop, "$prop survives $class->new with true value"; 33 | ok !$g->$_, "$prop opposite=$_ right" for @$opposites; 34 | $g = $g->copy; 35 | ok $g->$prop, "$prop survives copy"; 36 | } 37 | 38 | { 39 | eval { Graph->new(foobar => 1) }; 40 | like($@, qr/Graph::new: Unknown option: 'foobar' /); 41 | eval { Graph->new(foobar => 0) }; 42 | like($@, qr/Graph::new: Unknown option: 'foobar' /); 43 | eval { Graph->new(foobar => 1, barfoo => 1) }; 44 | like($@, qr/Graph::new: Unknown options: 'barfoo' 'foobar' /); 45 | } 46 | 47 | { 48 | my $g = Graph->new(vertices => [0, 1, 2]); 49 | ok($g->has_vertex(0)); 50 | ok($g->has_vertex(1)); 51 | ok($g->has_vertex(2)); 52 | } 53 | 54 | { 55 | my $g = Graph->new(edges => [[0, 1], [2, 3]]); 56 | is $g, "0-1,2-3"; 57 | } 58 | 59 | { 60 | my $g = Graph->new(vertices => [0], edges => [[1, 2], [2, 3]]); 61 | ok($g->has_vertex(0)); 62 | is $g, "1-2,2-3,0"; 63 | } 64 | 65 | { 66 | my $g = Graph->new(multiedged => 1); 67 | my $h = $g->new; # The flags should be inherited. 68 | ok($h->is_multiedged); 69 | $h = $g->new(multiedged => 0); # The flags should be overridable 70 | ok !$h->is_multiedged; 71 | } 72 | 73 | use Graph::Directed; 74 | my $d = Graph::Directed->new; 75 | is(ref $d, 'Graph::Directed'); 76 | 77 | use Graph::Undirected; 78 | my $u = Graph::Undirected->new; 79 | is(ref $u, 'Graph::Undirected'); 80 | 81 | done_testing; 82 | -------------------------------------------------------------------------------- /t/07_gen.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 15; 3 | 4 | use Graph; 5 | 6 | my $g = Graph->new; 7 | 8 | gen_changed( $g->[1] ); # [1] is the generational index 9 | ok( $g->add_vertex('a') ); 10 | gen_changed( $g->[1] ); 11 | ok( $g->add_vertex('b') ); 12 | gen_changed( $g->[1] ); 13 | ok( $g->add_edge('a', 'b') ); 14 | gen_changed( $g->[1] ); 15 | ok( $g->delete_edge('a', 'b') ); 16 | gen_changed( $g->[1] ); 17 | ok( $g->add_edge('a', 'c') ); 18 | gen_changed( $g->[1] ); 19 | ok( $g->delete_vertex('a') ); 20 | gen_changed( $g->[1] ); 21 | ok( $g->delete_vertex('b') ); 22 | gen_changed( $g->[1] ); # delete vertex 23 | 24 | my $gen_old; 25 | sub gen_changed { 26 | isnt $_[0], $gen_old; 27 | $gen_old = $_[0],; 28 | } 29 | -------------------------------------------------------------------------------- /t/09_eq.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 14; 3 | 4 | use Graph; 5 | 6 | my $g = Graph->new; 7 | 8 | $g->add_vertices(qw(a b c d)); 9 | $g->add_path(qw(b c e f)); 10 | 11 | my $h = Graph->new; 12 | 13 | $h->add_vertices(qw(a b c d)); 14 | $h->add_path(qw(b c e f)); 15 | 16 | my $i = $h->new; 17 | 18 | $i->add_vertex(qw(g)); 19 | 20 | is($g, "b-c,c-e,e-f,a,d"); 21 | is("b-c,c-e,e-f,a,d", $g); 22 | 23 | ok($g->eq("b-c,c-e,e-f,a,d")); 24 | 25 | is($g, $h); 26 | is($h, $g); 27 | 28 | ok($g->eq($h)); 29 | ok($h->eq($g)); 30 | 31 | isnt($i, "b-c,c-e,e-f,a,d"); 32 | isnt("b-c,c-e,e-f,a,d", $i); 33 | 34 | ok($i->ne("b-c,c-e,e-f,a,d")); 35 | 36 | isnt($g, $i); 37 | isnt($i, $g); 38 | 39 | ok($g->ne($i)); 40 | ok($i->ne($g)); 41 | 42 | -------------------------------------------------------------------------------- /t/10_has_vertices.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | 3 | use Test::More tests => 3; 4 | 5 | use Graph; 6 | my $g = Graph->new; 7 | 8 | ok( !$g->has_vertices() ); 9 | 10 | $g->add_vertex("a"); 11 | 12 | ok( $g->has_vertices() ); 13 | 14 | $g->add_vertex("b"); 15 | 16 | ok( $g->has_vertices() ); 17 | 18 | -------------------------------------------------------------------------------- /t/11_vertices.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | 3 | use Test::More tests => 7; 4 | 5 | use Graph; 6 | my $g = Graph->new; 7 | 8 | ok( !$g->has_vertices() ); 9 | 10 | my $v = $g->vertices; 11 | 12 | is( $v, 0 ); 13 | 14 | my @v = $g->vertices; 15 | 16 | is( "@v", "" ); 17 | 18 | $g->add_vertex("a"); 19 | 20 | $v = $g->vertices; 21 | 22 | is( $v, 1 ); 23 | 24 | @v = $g->vertices; 25 | 26 | is( "@v", "a" ); 27 | 28 | $g->add_vertex("b"); 29 | 30 | $v = $g->vertices; 31 | 32 | is( $v, 2 ); 33 | 34 | @v = sort $g->vertices; 35 | 36 | is( "@v", "a b" ); 37 | 38 | -------------------------------------------------------------------------------- /t/12_has_vertex.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 7; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | ok( !$g->has_vertex("a") ); 8 | ok( !$g->has_vertex("b") ); 9 | 10 | ok( !$g->has_vertex("a") ); 11 | ok( !$g->has_vertex("b") ); 12 | 13 | $g->add_vertex("a"); 14 | 15 | ok( $g->has_vertex("a") ); 16 | 17 | ok( !$g->has_vertex("b") ); 18 | ok( !$g->has_vertex("b") ); 19 | 20 | -------------------------------------------------------------------------------- /t/13_add_vertex.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 6; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | ok( $g->add_vertex("a") ); 8 | ok( $g->add_vertex("b") ); 9 | 10 | is( $g->add_vertex("c"), $g ); 11 | 12 | eval { $g->add_vertex(undef) }; 13 | like($@, 14 | qr/Graph::add_vertex: undef vertex/); 15 | 16 | is( $g->add_vertices("x", "y"), $g ); 17 | 18 | is( $g, "a,b,c,x,y" ); 19 | -------------------------------------------------------------------------------- /t/14_delete_vertex.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 36; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | $g->add_vertex("a"); 8 | $g->add_vertex("b"); 9 | 10 | ok( $g->delete_vertex("b") ); 11 | ok( $g->has_vertex("a") ); 12 | ok( ! $g->has_vertex("b") ); 13 | ok( ! $g->has_vertex("c") ); 14 | 15 | ok( $g->delete_vertex("c") ); 16 | ok( $g->has_vertex("a") ); 17 | ok( ! $g->has_vertex("b") ); 18 | ok( ! $g->has_vertex("c") ); 19 | 20 | is( $g->delete_vertex("a"), "" ); 21 | is( $g->delete_vertex("a"), "" ); 22 | 23 | $g->add_vertices(qw(a b c d)); 24 | ok( $g->has_vertex("a") ); 25 | ok( $g->has_vertex("b") ); 26 | ok( $g->has_vertex("c") ); 27 | ok( $g->has_vertex("d") ); 28 | 29 | $g->delete_vertices(qw(a c)); 30 | ok( ! $g->has_vertex("a") ); 31 | ok( $g->has_vertex("b") ); 32 | ok( ! $g->has_vertex("c") ); 33 | ok( $g->has_vertex("d") ); 34 | 35 | $g->delete_vertices(qw(a c)); 36 | ok( ! $g->has_vertex("a") ); 37 | ok( $g->has_vertex("b") ); 38 | ok( ! $g->has_vertex("c") ); 39 | ok( $g->has_vertex("d") ); 40 | 41 | $g->delete_vertices(qw(b d)); 42 | ok( ! $g->has_vertex("a") ); 43 | ok( ! $g->has_vertex("b") ); 44 | ok( ! $g->has_vertex("c") ); 45 | ok( ! $g->has_vertex("d") ); 46 | 47 | is( $g->delete_vertex(), $g ); 48 | is( $g->delete_vertices(), $g ); 49 | 50 | my $h = Graph->new(countvertexed => 1); 51 | 52 | $h->add_vertices(qw(a a b b)); 53 | ok( $h->has_vertex("a") ); 54 | ok( $h->has_vertex("b") ); 55 | 56 | $h->delete_vertex('a'); 57 | ok( $h->has_vertex("a") ); 58 | $h->delete_vertex('a'); 59 | ok( ! $h->has_vertex("a") ); 60 | 61 | $h->delete_vertices('b'); 62 | ok( $h->has_vertices("b") ); 63 | $h->delete_vertices('b'); 64 | ok( ! $h->has_vertices("b") ); 65 | 66 | { 67 | # From Andras Salamon 68 | use Graph::Directed; 69 | my $f = new Graph::Directed; 70 | $f->add_edges( qw( a a a b ) ); # notice self-loop 71 | is($f, "a-a,a-b"); 72 | $f->delete_vertex('a'); 73 | is($f, "b"); 74 | } 75 | 76 | -------------------------------------------------------------------------------- /t/16_edges.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 48; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | is $g, ""; 8 | ok( !$g->has_edges() ); 9 | is( $g->edges, 0 ); 10 | is( "@{[$g->edges]}", "" ); 11 | ok( !$g->any_edge("a", "b") ); 12 | ok( !$g->any_edge("b", "a") ); 13 | ok( !$g->any_edge("b", "c") ); 14 | ok( !$g->any_edge("c", "b") ); 15 | 16 | $g->add_edge("a", "b"); 17 | is $g, "a-b"; 18 | ok( $g->has_edges() ); 19 | is( $g->edges, 1 ); 20 | is( "@{[map { qq{[@$_]} } $g->edges]}", "[a b]" ); 21 | ok( $g->any_edge("a", "b") ); 22 | ok( !$g->any_edge("b", "a") ); 23 | ok( !$g->any_edge("b", "c") ); 24 | ok( !$g->any_edge("c", "b") ); 25 | 26 | $g->add_edge("b", "c"); 27 | is $g, "a-b,b-c"; 28 | ok( $g->has_edges() ); 29 | is( $g->edges, 2 ); 30 | is( "@{[sort map { qq{[@$_]} } $g->edges]}", "[a b] [b c]" ); 31 | ok( $g->any_edge("a", "b") ); 32 | ok( !$g->any_edge("b", "a") ); 33 | ok( $g->any_edge("b", "c") ); 34 | ok( !$g->any_edge("c", "b") ); 35 | 36 | eval { $g->add_edges("x") }; 37 | like($@, qr/Graph::add_edges: missing end vertex/); 38 | 39 | is($g->add_edges("x", "y"), $g); 40 | is($g, "a-b,b-c,x-y"); 41 | 42 | eval { $g->add_edge("c", "d", "e", "f") }; 43 | like($@, 44 | qr/Graph::add_edge: expected hyperedged graph/); 45 | 46 | eval { $g->add_edge("c") }; 47 | like($@, 48 | qr/Graph::add_edge: expected hyperedged graph/); 49 | 50 | ok( $g->delete_edge("b", "c") ); 51 | is $g, "a-b,x-y,c"; 52 | 53 | ok( $g->delete_edge("b", "d") ); 54 | is $g, "a-b,x-y,c"; 55 | 56 | is( $g->delete_edge("a", "b"), 'x-y,a,b,c' ); 57 | is( $g->delete_edge("a", "b"), 'x-y,a,b,c' ); 58 | 59 | $g->add_edges(qw(a b b x c d c y)); 60 | is $g, "a-b,b-x,c-d,c-y,x-y"; 61 | 62 | $g->delete_edges(qw(a b c d)); 63 | is $g, "b-x,c-y,x-y,a,d"; 64 | 65 | $g->delete_edges(qw(a b c d)); 66 | is $g, "b-x,c-y,x-y,a,d"; 67 | 68 | $g->delete_edges(qw(b x c y)); 69 | is $g, "x-y,a,b,c,d"; 70 | 71 | is( $g->delete_edge(), $g ); 72 | is( $g->delete_edges(), $g ); 73 | 74 | my $h = Graph->new(countedged => 1); 75 | 76 | $h->add_edges(qw(a x a x b y b y)); 77 | is $h, "a-x,b-y"; 78 | 79 | $h->delete_edge('a', 'x'); 80 | is $h, "a-x,b-y"; 81 | $h->delete_edge('a', 'x'); 82 | is $h, "b-y,a,x"; 83 | 84 | $h->delete_edges('b', 'y'); 85 | ok( $h->has_edges ); # takes no args 86 | ok( $h->has_edges("b", "y") ); 87 | $h->delete_edges('b', 'y'); 88 | ok( ! $h->has_edges ); 89 | ok( ! $h->has_edges("b", "y") ); 90 | -------------------------------------------------------------------------------- /t/20_countvertexed.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 28; 3 | 4 | use Graph; 5 | 6 | my $g1 = Graph->new; 7 | 8 | ok ( !$g1->countvertexed ); 9 | 10 | my $g2 = Graph->new( countvertexed => 1 ); 11 | 12 | ok ( $g2->countvertexed ); 13 | 14 | is( $g2->vertices, 0 ); 15 | is( $g2->unique_vertices, 0 ); 16 | 17 | ok( $g2->add_vertex('a') ); 18 | is( $g2->vertices, 1 ); 19 | is( $g2->unique_vertices, 1 ); 20 | 21 | ok( $g2->add_vertex('a') ); 22 | is( $g2->vertices, 2 ); 23 | is( $g2->unique_vertices, 1 ); 24 | 25 | ok( $g2->add_vertex('b') ); 26 | is( $g2->vertices, 3 ); 27 | is( $g2->unique_vertices, 2 ); 28 | 29 | ok( $g2->add_vertex('a') ); 30 | is( $g2->vertices, 4 ); 31 | is( $g2->unique_vertices, 2 ); 32 | 33 | ok( $g2->delete_vertex('b') ); 34 | is( $g2->vertices, 3 ); 35 | is( $g2->unique_vertices, 1 ); 36 | 37 | ok( $g2->delete_vertex('a') ); 38 | is( $g2->vertices, 2 ); 39 | is( $g2->unique_vertices, 1 ); 40 | 41 | ok( $g2->delete_vertex('a') ); 42 | is( $g2->vertices, 1 ); 43 | is( $g2->unique_vertices, 1 ); 44 | 45 | is( $g2->delete_vertex('a'), "" ); 46 | is( $g2->vertices, 0 ); 47 | is( $g2->unique_vertices, 0 ); 48 | 49 | -------------------------------------------------------------------------------- /t/21_multivertexed.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph; 5 | my $g = Graph->new(multivertexed => 1); 6 | ok $g->multivertexed; 7 | 8 | is( $g->get_vertex_count('a'), 0 ); 9 | ok( $g->add_vertex_by_id('a', 'red') ); 10 | is( $g->get_vertex_count('a'), 1 ); 11 | 12 | for (1,2) { 13 | ok( $g->has_vertex('a') ); 14 | ok(!$g->has_vertex('b') ); 15 | ok( $g->has_vertex_by_id('a', 'red') ); 16 | ok(!$g->has_vertex_by_id('a', 'blue') ); 17 | } 18 | 19 | $g->add_vertex_by_id('a', 'blue'); 20 | is( $g->get_vertex_count('a'), 2 ); 21 | 22 | ok( $g->has_vertex_by_id('a', $_) ) for qw(blue red); 23 | 24 | $g->add_vertex('a'); 25 | ok( $g->has_vertex('a') ); 26 | ok(!$g->has_vertex('b') ); 27 | is( $g->get_vertex_count('a'), 3 ); 28 | 29 | is( $g->add_vertex_get_id('a'), $_) for 1..3; 30 | ok( $g->has_vertex_by_id('a', $_) ) for 0..3; 31 | 32 | is( $g->get_vertex_count('a'), 6 ); 33 | 34 | ok( $g->delete_vertex_by_id('a', 'blue') ); 35 | ok(!$g->has_vertex_by_id('a', 'blue') ); 36 | ok( $g->has_vertex_by_id('a', 'red') ); 37 | 38 | ok( $g->delete_vertex_by_id('a', 'green') ); 39 | ok(!$g->has_vertex_by_id('a', $_)) for qw(blue green); 40 | 41 | ok( $g->has_vertex_by_id('a', 'red') ); 42 | ok( $g->delete_vertex_by_id('a', 'red') ); 43 | 44 | my $got = [ sort $g->get_multivertex_ids('a') ]; 45 | is_deeply $got, [ qw(0 1 2 3) ] or diag explain $got; 46 | is( $g->get_vertex_count('a'), 4 ); 47 | 48 | ok $g->add_edge('a', 'b'); 49 | is $g, "a-b"; 50 | $got = [ $g->successors('a') ]; 51 | is_deeply $got, [ 'b' ] or diag explain $got; 52 | $got = [ $g->predecessors('b') ]; 53 | is_deeply $got, [ 'a' ] or diag explain $got; 54 | 55 | is( $g->delete_vertex('a'), 'b' ); 56 | ok(!$g->has_vertex_by_id('a', $_) ) for 0..3; 57 | is( $g->get_multivertex_ids('a'), undef ); 58 | 59 | ok $g->add_edge('a', 'b'); 60 | is $g, "a-b"; 61 | ok( $g->add_vertex_by_id('b', 'bob') ); 62 | is $g, "a-b"; 63 | ok( $g->delete_vertex_by_id('b', '0') ); 64 | is $g, "a-b"; 65 | ok( $g->delete_vertex_by_id('b', 'bob') ); 66 | is $g, "a"; 67 | 68 | my $h = Graph->new; 69 | 70 | eval { $h->add_vertex_by_id("b", "black") }; 71 | like($@, qr/add_vertex_by_id: expected multivertexed/); 72 | 73 | eval { $h->has_vertex_by_id("b", "black") }; 74 | like($@, qr/has_vertex_by_id: expected multivertexed/); 75 | 76 | eval { $h->get_multivertex_ids() }; 77 | like($@, qr/get_multivertex_ids: expected multivertexed/); 78 | 79 | eval { $h->delete_vertex_by_id("b", "black") }; 80 | like($@, qr/delete_vertex_by_id: expected multivertexed/); 81 | 82 | eval { Graph->new( multivertexed => 1, countvertexed => 1 ) }; 83 | like ( $@, qr/both countvertexed and multivertexed/ ); 84 | 85 | done_testing; 86 | -------------------------------------------------------------------------------- /t/22_refvertexed.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 6; 3 | 4 | use Graph; 5 | 6 | my $g1 = Graph->new; 7 | 8 | ok ( !$g1->refvertexed ); 9 | 10 | my $g2 = Graph->new( refvertexed => 1 ); 11 | 12 | ok ( $g2->refvertexed ); 13 | 14 | { 15 | # rt.cpan.org 78465 find_a_cycle and has_cycle are broken 16 | my $v1 = \1; 17 | my $v2 = \2; 18 | my $graph = Graph->new( directed => 1, refvertexed => 1, edges => [[$v1, $v2], [$v2, $v1]] ); 19 | my @v = $graph->vertices(); 20 | ok($graph->has_a_cycle); 21 | my @c = $graph->find_a_cycle; 22 | is(@c, 2); 23 | if ($c[0] == $v1) { 24 | is_deeply($c[0], $v1); 25 | is_deeply($c[1], $v2); 26 | } else { 27 | is_deeply($c[0], $v2); 28 | is_deeply($c[1], $v1); 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /t/24_mixvertexed.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 56; 3 | 4 | use Graph; 5 | 6 | for my $m (0, 1) { 7 | for my $r (0, 1) { 8 | my $g = Graph->new(countvertexed => $m, 9 | refvertexed => $r); 10 | note "countvertexed = $m, refvertexed = $r"; 11 | $g->add_vertex("a"); 12 | $g->add_vertex("a"); 13 | $g->add_vertex(my $b = []); 14 | $g->add_vertex($b); 15 | for (1, 2) { 16 | ok( $g->has_vertices( ) ); 17 | ok( $g->has_vertex("a") ); 18 | ok( $g->has_vertex($b ) ); 19 | ok( !$g->has_vertex("e") ); 20 | is( $g->get_vertex_count("a"), $m ? 2 : 1 ); 21 | is( $g->get_vertex_count($b ), $m ? 2 : 1 ); 22 | is( $g->get_vertex_count("e"), 0 ); 23 | } 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /t/25_countedged.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 28; 3 | 4 | use Graph; 5 | 6 | my $g1 = Graph->new; 7 | 8 | ok ( !$g1->countedged ); 9 | 10 | my $g2 = Graph->new( countedged => 1 ); 11 | 12 | ok ( $g2->countedged ); 13 | 14 | is( $g2->edges, 0 ); 15 | is( $g2->unique_edges, 0 ); 16 | 17 | ok( $g2->add_edge('a', 'b') ); 18 | is( $g2->edges, 1 ); 19 | is( $g2->unique_edges, 1 ); 20 | 21 | ok( $g2->add_edge('a', 'b') ); 22 | is( $g2->edges, 2 ); 23 | is( $g2->unique_edges, 1 ); 24 | 25 | ok( $g2->add_edge('b', 'c') ); 26 | is( $g2->edges, 3 ); 27 | is( $g2->unique_edges, 2 ); 28 | 29 | ok( $g2->add_edge('a', 'b') ); 30 | is( $g2->edges, 4 ); 31 | is( $g2->unique_edges, 2 ); 32 | 33 | ok( $g2->delete_edge('b', 'c') ); 34 | is( $g2->edges, 3 ); 35 | is( $g2->unique_edges, 1 ); 36 | 37 | ok( $g2->delete_edge('a', 'b') ); 38 | is( $g2->edges, 2 ); 39 | is( $g2->unique_edges, 1 ); 40 | 41 | ok( $g2->delete_edge('a', 'b') ); 42 | is( $g2->edges, 1 ); 43 | is( $g2->unique_edges, 1 ); 44 | 45 | ok( $g2->delete_edge('a', 'b') ); 46 | is( $g2->edges, 0 ); 47 | is( $g2->unique_edges, 0 ); 48 | 49 | -------------------------------------------------------------------------------- /t/26_multiedged.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 61; 3 | 4 | use Graph; 5 | my $g = Graph->new(multiedged => 1); 6 | 7 | is( $g->get_edge_count('a', 'b'), 0 ); 8 | 9 | ok( $g->add_edge_by_id('a', 'b', 'red') ); 10 | 11 | is( $g->get_edge_count('a', 'b'), 1 ); 12 | 13 | is $g, "a-b"; 14 | 15 | ok( $g->has_edge_by_id('a', 'b', 'red') ); 16 | ok(!$g->has_edge_by_id('a', 'b', 'blue') ); 17 | 18 | ok( $g->has_edge_by_id('a', 'b', 'red') ); 19 | ok(!$g->has_edge_by_id('a', 'b', 'blue') ); 20 | 21 | $g->add_edge_by_id('a', 'b', 'blue'); 22 | 23 | is( $g->get_edge_count('a', 'b'), 2 ); 24 | 25 | ok( $g->has_edge_by_id('a', 'b', 'blue') ); 26 | ok( $g->has_edge_by_id('a', 'b', 'red') ); 27 | 28 | $g->add_edge('a', 'b'); 29 | is $g, "a-b"; 30 | 31 | is( $g->get_edge_count('a', 'b'), 3 ); 32 | 33 | is( $g->add_edge_get_id('a', 'b'), 1); 34 | is( $g->add_edge_get_id('a', 'b'), 2); 35 | is( $g->add_edge_get_id('a', 'b'), 3); 36 | 37 | is( $g->get_edge_count('a', 'b'), 6 ); 38 | 39 | ok( $g->delete_edge_by_id('a', 'b', 'blue') ); 40 | 41 | ok(!$g->has_edge_by_id('a', 'b', 'blue') ); 42 | ok( $g->has_edge_by_id('a', 'b', 'red') ); 43 | 44 | ok(!$g->delete_edge_by_id('a', 'b', 'green') ); 45 | 46 | ok(!$g->has_edge_by_id('a', 'b', 'blue') ); 47 | ok( $g->has_edge_by_id('a', 'b', 'red') ); 48 | ok(!$g->has_edge_by_id('a', 'b', 'green') ); 49 | 50 | ok( $g->delete_edge_by_id('a', 'b', 'red') ); 51 | 52 | my @i = sort $g->get_multiedge_ids('a', 'b'); 53 | 54 | is("@i", "0 1 2 3"); 55 | 56 | ok( $g->has_edge_by_id('a', 'b', '0') ); 57 | ok( $g->has_edge_by_id('a', 'b', '1') ); 58 | ok( $g->has_edge_by_id('a', 'b', '2') ); 59 | ok( $g->has_edge_by_id('a', 'b', '3') ); 60 | 61 | is( $g->get_edge_count('a', 'b'), 4 ); 62 | 63 | is( $g->delete_edge('a', 'b'), 'a,b' ); 64 | 65 | ok(!$g->has_edge_by_id('a', 'b', '0') ); 66 | ok(!$g->has_edge_by_id('a', 'b', '1') ); 67 | ok(!$g->has_edge_by_id('a', 'b', '2') ); 68 | ok(!$g->has_edge_by_id('a', 'b', '3') ); 69 | 70 | is( $g->get_multiedge_ids('a', 'b'), undef ); 71 | 72 | is( $g->add_edge_get_id('a', 'b'), 0); 73 | ok( $g->delete_edge_by_id('a', 'b', 0) ); # exercise deleting last one 74 | 75 | my $h = Graph->new; 76 | 77 | eval { $h->add_edge_by_id("b", "c", "black") }; 78 | like($@, qr/add_edge_by_id: expected multiedged/); 79 | 80 | eval { $h->has_edge_by_id("b", "c", "black") }; 81 | like($@, qr/has_edge_by_id: expected multiedged/); 82 | 83 | eval { $h->get_multiedge_ids() }; 84 | like($@, qr/get_multiedge_ids: expected multiedged/); 85 | 86 | eval { $h->delete_edge_by_id("b", "c", "black") }; 87 | like($@, qr/delete_edge_by_id: expected multiedged/); 88 | 89 | $h = Graph->new(multiedged => 1, hyperedged => 1, directed => 0); 90 | 91 | ok( $h->add_edge_by_id('u', 'v', 'w', 'genghis') ); 92 | ok( $h->add_edge_by_id('u', 'khan') ); 93 | 94 | ok( $h->has_edge('u' ,'v', 'w') ); 95 | ok(!$h->has_edge('u' ,'v') ); 96 | ok( $h->any_edge('u' ,'v') ); 97 | ok( $h->any_edge('u' ,'w') ); 98 | ok( $h->any_edge('v' ,'w') ); 99 | ok( $h->has_edge('u') ); 100 | ok(!$h->has_edge('v') ); 101 | ok(!$h->has_edge() ); 102 | 103 | ok( $h->has_edge_by_id('u', 'v', 'w', 'genghis') ); 104 | ok( $h->has_edge_by_id('u', 'khan') ); 105 | 106 | eval { Graph->new( multiedged => 1, countedged => 1 ) }; 107 | 108 | like ( $@, qr/both countedged and multiedged/ ); 109 | 110 | { 111 | my $g4a = Graph->new(undirected => 1, multiedged => 1); 112 | 113 | $g4a->add_edge_get_id("a1","s1"); 114 | $g4a->add_edge_get_id("a2","s2"); 115 | $g4a->add_edge_get_id("a2","a1"); # Last. 116 | 117 | my @e = $g4a->edges; 118 | is(@e, 3); 119 | 120 | my $g4b = Graph->new(undirected => 1, multiedged => 1); 121 | 122 | $g4b->add_edge_get_id("a2","a1"); # First. 123 | $g4b->add_edge_get_id("a1","s1"); 124 | $g4b->add_edge_get_id("a2","s2"); 125 | 126 | @e = $g4b->edges; 127 | is(@e, 3); 128 | } 129 | 130 | { 131 | # rt.cpan.org 107567 edges() missing on undirected multiedged graph 132 | my $graph = Graph->new(undirected => 1, multiedged => 1); 133 | $graph->add_vertex(0); 134 | $graph->add_vertex(1); 135 | $graph->add_edge(1,0); 136 | is($graph, "0=1"); 137 | my @edges = $graph->edges; 138 | is_deeply(@edges, [0, 1]) or diag explain \@edges; 139 | is($graph->edges, 1); 140 | } 141 | -------------------------------------------------------------------------------- /t/30_mixedged.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 36; 3 | 4 | use Graph; 5 | 6 | my %EXPECT = ( 7 | "0 0" => "a=b", 8 | "0 1" => "a=b,c=d=e", 9 | "1 0" => "a=b", 10 | "1 1" => "a=b,c=d=e", 11 | ); 12 | 13 | for my $m (0, 1) { 14 | for my $h (0, 1) { 15 | my $g = Graph->new(countedged => $m, 16 | hyperedged => $h, directed => 0); 17 | note "c = $m, h = $h\n"; 18 | $g->add_edge("a", "b"); 19 | $g->add_edge("a", "b"); 20 | if ($g->hyperedged) { 21 | $g->add_edge("c", "d", "e"); 22 | $g->add_edge("c", "d", "e"); 23 | } 24 | for (1, 2) { 25 | ok( $g->has_vertices( ) ); 26 | is $g, $EXPECT{"$m $h"}; 27 | } 28 | for (1, 2) { 29 | is( $g->get_edge_count("a", "b"), $m ? 2 : 1 ); 30 | if ($g->hyperedged) { 31 | is( $g->get_edge_count("c", "d", "e"), $m ? 2 : 1 ); 32 | } 33 | is( $g->get_edge_count("e", "f"), 0 ); 34 | } 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /t/33_hyperedge.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph; 5 | my $g = Graph->new(hyperedged => 1, directed => 0); 6 | 7 | $g->add_edge(); 8 | $g->add_edge("a"); 9 | $g->add_edge("b", "c"); 10 | $g->add_edge("d", "e", "f"); 11 | 12 | is( $g->edges, 4 ); 13 | 14 | my @e = $g->edges; 15 | 16 | is ( "@{[ sort map { qq'[@$_]' } @e ]}", "[] [a] [b c] [d e f]" ); 17 | 18 | ok( $g->has_edge() ); 19 | ok( $g->has_edge("a") ); 20 | ok( $g->has_edge("b", "c") ); 21 | ok( $g->has_edge("d", "e", "f") ); 22 | ok( $g->any_edge("d", "e", "f") ); 23 | ok( $g->any_edge("e", "f") ); 24 | ok( $g->any_edge("f", "e") ); 25 | ok( !$g->any_edge("a", "e") ); 26 | 27 | ok( ! $g->has_edge("b") ); 28 | ok( ! $g->has_edge("c") ); 29 | ok( ! $g->has_edge("d", "e") ); 30 | 31 | $g->add_edge("d", "e", "g"); 32 | 33 | is $g, ",a,b=c,d=e=f,d=e=g"; 34 | 35 | is( $g->delete_edge("d", "e", "f"), $g ); 36 | is $g, ",a,b=c,d=e=g,f"; 37 | 38 | ok( ! $g->has_edge("d", "e", "f") ); 39 | ok( $g->has_edge("d", "e", "g") ); 40 | 41 | is( $g->delete_edge("d", "e", "f"), $g ); 42 | 43 | is ( "@{[ sort map { qq'[@$_]' } $g->edges ]}", "[] [a] [b c] [d e g]" ); 44 | 45 | $g = Graph->new(hyperedged => 1, directed => 1); 46 | 47 | $g->set_edge_attributes([qw(a b c)], [qw(f g)], 48 | { color => 'pearl', weight => 'heavy' }); 49 | $g->add_weighted_edge([qw(a b c)], [qw(f h)], 123); 50 | $g->add_weighted_path(["c"], 45, ["d"], 46, ["e"]); 51 | 52 | ok !$g->has_edge([qw(a c)], [qw(f g)]); 53 | ok( $g->any_edge("c", "g") ); 54 | ok( $g->any_edge("c", "d") ); 55 | ok( !$g->any_edge("b", "d") ); 56 | ok $g->has_edge([qw(a b c)], [qw(f g)]) or diag explain $g; 57 | ok $g->has_edge([qw(b a c)], [qw(f g)]); 58 | ok $g->has_edge([qw(a b c)], [qw(f h)]) or diag explain $g; 59 | ok !$g->has_edge([qw(f h)], [qw(a b c)]) or diag explain $g; 60 | ok $g->has_edge([qw(c)], [qw(d)]) or diag explain $g; 61 | ok $g->has_edge([qw(d)], [qw(e)]) or diag explain $g; 62 | is_deeply [ $g->edges_to('e') ], [ [['d'], ['e']] ]; 63 | is_deeply [ $g->edges_from('d') ], [ [[qw(d)], [qw(e)]] ]; 64 | is_deeply [ $g->edges_at('e') ], [ [[qw(d)], [qw(e)]] ] or diag explain [ $g->edges_at('e') ]; 65 | is_deeply [ sort $g->successors('c') ], [qw(d f g h)]; 66 | is_deeply [ $g->predecessors('e') ], [qw(d)]; 67 | is $g, "[a,b,c]-[f,g],[a,b,c]-[f,h],[c]-[d],[d]-[e]"; 68 | 69 | done_testing; 70 | -------------------------------------------------------------------------------- /t/39_edges_at.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 14; 3 | 4 | use Graph; 5 | my $g = Graph->new(hyperedged => 1, directed => 0); 6 | 7 | $g->add_edge("a", "b"); 8 | $g->add_edge("d" ,"e"); 9 | $g->add_edge("a", "b", "c"); 10 | 11 | sub deref { 12 | my $r = shift; 13 | ref $r ? "[" . join(" ", sort map { deref($_) } @$r) . "]" : $_; 14 | } 15 | 16 | sub at { 17 | join(" ", sort map { deref($_) } $g->edges_at(@_)); 18 | } 19 | 20 | is( at("a"), "[a b c] [a b]"); 21 | is( at("b"), "[a b c] [a b]"); 22 | is( at("c"), "[a b c]"); 23 | is( at("d"), "[d e]"); 24 | is( at("e"), "[d e]"); 25 | is( at("x"), ""); 26 | 27 | { 28 | # [cpan #11543] self-edges reported twice in edges_at 29 | use Graph::Directed; 30 | my $g1 = new Graph::Directed(); 31 | $g1->add_edge(0,0); 32 | is(scalar $g1->edges_at(0), 1); 33 | is("@{ ($g1->edges_at(0))[0] }", "0 0"); 34 | } 35 | 36 | { 37 | my $g2 = new Graph::Directed(); 38 | $g2->add_edge(1,1); 39 | $g2->add_edge(1,2); 40 | my @e1 = $g2->edges_at(1); 41 | is(@e1, 2); 42 | @e1[1, 0] = @e1[0, 1] if $e1[0]->[1] > $e1[1]->[1]; 43 | is("@{ $e1[0] }", "1 1"); 44 | is("@{ $e1[1] }", "1 2"); 45 | my @e2 = $g2->edges_at(2); 46 | is(@e2, 1); 47 | is("@{ $e2[0] }", "1 2"); 48 | my @e3 = $g2->edges_at(3); 49 | is(@e3, 0); 50 | } 51 | -------------------------------------------------------------------------------- /t/40_edges_from.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 16; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | $g->add_edge("a", "b"); 8 | $g->add_edge("b", "c"); 9 | $g->add_edge("c", "d"); 10 | $g->add_edge("d", "d"); 11 | $g->add_edge("e", "b"); 12 | $g->add_edge("c", "f"); 13 | $g->add_edge("c", "g"); 14 | $g->add_edge("g", "h"); 15 | $g->add_edge("h", "g"); 16 | 17 | sub from { 18 | join(" ", sort map { "[" . join(" ", map { ref $_ ? "[@$_]" : $_ } @$_) . "]" } $g->edges_from(@_)); 19 | } 20 | 21 | is( from("a"), "[a b]"); 22 | is( from("b"), "[b c]"); 23 | is( from("c"), "[c d] [c f] [c g]"); 24 | is( from("d"), "[d d]"); 25 | is( from("e"), "[e b]"); 26 | is( from("f"), ""); 27 | is( from("g"), "[g h]"); 28 | is( from("h"), "[h g]"); 29 | is( from("x"), ""); 30 | 31 | { 32 | use Graph::Directed; 33 | my $g1 = new Graph::Directed(); 34 | $g1->add_edge(0,0); 35 | my @e = $g1->edges_from(0); 36 | is(@e, 1); 37 | is("@{ $e[0] }", "0 0"); 38 | } 39 | 40 | { 41 | my $g2 = new Graph::Directed(); 42 | $g2->add_edge(1,1); 43 | $g2->add_edge(1,2); 44 | my @e1 = $g2->edges_from(1); 45 | is(@e1, 2); 46 | @e1[1, 0] = @e1[0, 1] if $e1[0]->[1] > $e1[1]->[1]; 47 | is("@{ $e1[0] }", "1 1"); 48 | is("@{ $e1[1] }", "1 2"); 49 | my @e2 = $g2->edges_from(2); 50 | is(@e2, 0); 51 | my @e3 = $g2->edges_from(0); 52 | is(@e3, 0); 53 | } 54 | -------------------------------------------------------------------------------- /t/41_edges_to.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 16; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | $g->add_edge("a", "b"); 8 | $g->add_edge("b", "c"); 9 | $g->add_edge("c", "d"); 10 | $g->add_edge("d", "d"); 11 | $g->add_edge("e", "b"); 12 | $g->add_edge("c", "f"); 13 | $g->add_edge("c", "g"); 14 | $g->add_edge("g", "h"); 15 | $g->add_edge("h", "g"); 16 | 17 | sub to { 18 | join(" ", sort map { "[" . join(" ", map { ref $_ ? "[@$_]" : $_ } @$_) . "]" } $g->edges_to(@_)); 19 | } 20 | 21 | is( to("a"), ""); 22 | is( to("b"), "[a b] [e b]"); 23 | is( to("c"), "[b c]"); 24 | is( to("d"), "[c d] [d d]"); 25 | is( to("e"), ""); 26 | is( to("f"), "[c f]"); 27 | is( to("g"), "[c g] [h g]"); 28 | is( to("h"), "[g h]"); 29 | is( to("x"), ""); 30 | 31 | { 32 | use Graph::Directed; 33 | my $g1 = new Graph::Directed(); 34 | $g1->add_edge(0,0); 35 | my @e = $g1->edges_to(0); 36 | is(@e, 1); 37 | is("@{ $e[0] }", "0 0"); 38 | } 39 | 40 | { 41 | my $g2 = new Graph::Directed(); 42 | $g2->add_edge(1,1); 43 | $g2->add_edge(1,2); 44 | my @e1 = $g2->edges_to(1); 45 | is(@e1, 1); 46 | is("@{ $e1[0] }", "1 1"); 47 | my @e2 = $g2->edges_to(2); 48 | is(@e2, 1); 49 | is("@{ $e2[0] }", "1 2"); 50 | my @e3 = $g2->edges_to(3); 51 | is(@e3, 0); 52 | } 53 | -------------------------------------------------------------------------------- /t/42_add_path.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 16; 3 | 4 | use Graph; 5 | 6 | my $g = Graph->new; 7 | $g->add_path("a", "b", "c"); # @todo: hyperedges 8 | is $g, "a-b,b-c"; 9 | ok( $g->has_path("a", "b", "c") ); 10 | ok( ! $g->has_path("a", "c", "b") ); 11 | ok( ! $g->has_path("b", "a", "c") ); 12 | ok( ! $g->has_path("b", "c", "a") ); 13 | ok( ! $g->has_path("c", "a", "b") ); 14 | ok( ! $g->has_path("c", "b", "a") ); 15 | 16 | my $h = Graph->new(undirected => 1); # @todo: hyperedges 17 | $h->add_path("a", "b", "c"); 18 | is $h, "a=b,b=c"; 19 | ok( $h->has_path("a", "b", "c") ); 20 | ok( ! $h->has_path("a", "c", "b") ); 21 | ok( ! $h->has_path("b", "a", "c") ); 22 | ok( ! $h->has_path("b", "c", "a") ); 23 | ok( ! $h->has_path("c", "a", "b") ); 24 | ok( $h->has_path("c", "b", "a") ); 25 | 26 | $g = Graph->new; 27 | $g->add_path("a", "b", "c", "d", "e"); 28 | $g->delete_path("a", "b", "c"); 29 | is $g, "c-d,d-e,a,b"; 30 | 31 | $h = Graph->new(undirected => 1); 32 | $h->add_path("a", "b", "c", "d", "e"); 33 | $h->delete_path("a", "b", "c"); 34 | is $h, "c=d,d=e,a,b"; 35 | -------------------------------------------------------------------------------- /t/45_add_cycle.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 13; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | $g->add_cycle("a", "b", "c", "d", "e"); 8 | is $g, "a-b,b-c,c-d,d-e,e-a"; 9 | 10 | ok( $g->has_cycle(qw(a b c d e)) ); 11 | ok( ! $g->has_cycle(qw(a c b d e)) ); 12 | ok( ! $g->has_cycle(qw(b a c d e)) ); 13 | ok( $g->has_cycle(qw(e a b c d)) ); 14 | ok( ! $g->has_cycle(qw(e d a b c)) ); 15 | 16 | $g->delete_cycle("a", "b", "c"); 17 | is $g, "c-d,d-e,e-a,b"; 18 | 19 | my $h = Graph->new(undirected => 1); 20 | $h->add_cycle("a", "b", "c", "d", "e"); 21 | is $h, "a=b,a=e,b=c,c=d,d=e"; 22 | ok( $h->has_cycle(qw(a b c d e)) ); 23 | ok( $h->has_cycle(qw(e a b c d)) ); 24 | ok( ! $h->has_cycle(qw(a b d c e)) ); 25 | 26 | $h->delete_cycle("a", "b", "c"); 27 | is $h, "a=e,c=d,d=e,b"; 28 | 29 | ok(! $g->has_cycle()); 30 | -------------------------------------------------------------------------------- /t/48_get_vertex_count.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 12; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | is( $g->get_vertex_count("a"), 0 ); 8 | is( $g->get_vertex_count("b"), 0 ); 9 | 10 | $g->add_vertex("a"); 11 | 12 | is( $g->get_vertex_count("a"), 1 ); 13 | is( $g->get_vertex_count("b"), 0 ); 14 | 15 | $g->add_vertex("a"); 16 | 17 | is( $g->get_vertex_count("a"), 1 ); 18 | is( $g->get_vertex_count("b"), 0 ); 19 | 20 | my $h = $g->new(countvertexed => 1); 21 | 22 | $h->add_vertex("a"); 23 | $h->add_vertex("a"); 24 | 25 | is( $h->get_vertex_count("a"), 2 ); 26 | is( $h->get_vertex_count("b"), 0 ); 27 | 28 | $h->delete_vertex("a"); 29 | 30 | is( $h->get_vertex_count("a"), 1 ); 31 | is( $h->get_vertex_count("b"), 0 ); 32 | 33 | $h->delete_vertex("a"); 34 | 35 | is( $h->get_vertex_count("a"), 0 ); 36 | is( $h->get_vertex_count("b"), 0 ); 37 | 38 | -------------------------------------------------------------------------------- /t/49_get_edge_count.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 12; 3 | 4 | use Graph; 5 | my $g = Graph->new; 6 | 7 | is( $g->get_edge_count("a", "b"), 0 ); 8 | is( $g->get_edge_count("b", "c"), 0 ); 9 | 10 | $g->add_edge("a", "b"); 11 | 12 | is( $g->get_edge_count("a", "b"), 1 ); 13 | is( $g->get_edge_count("b", "c"), 0 ); 14 | 15 | $g->add_edge("a", "b"); 16 | 17 | is( $g->get_edge_count("a", "b"), 1 ); 18 | is( $g->get_edge_count("b", "c"), 0 ); 19 | 20 | my $h = $g->new(countedged => 1); 21 | 22 | $h->add_edge("a", "b"); 23 | $h->add_edge("a", "b"); 24 | 25 | is( $h->get_edge_count("a", "b"), 2 ); 26 | is( $h->get_edge_count("b", "c"), 0 ); 27 | 28 | $h->delete_edge("a", "b"); 29 | 30 | is( $h->get_edge_count("a", "b"), 1 ); 31 | is( $h->get_edge_count("b", "c"), 0 ); 32 | 33 | $h->delete_edge("a", "b"); 34 | 35 | is( $h->get_edge_count("a", "b"), 0 ); 36 | is( $h->get_edge_count("b", "c"), 0 ); 37 | 38 | -------------------------------------------------------------------------------- /t/50_vertex_attributes.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 187; 3 | 4 | use Graph; 5 | use Graph::Directed; 6 | use Graph::Undirected; 7 | 8 | my @ARGS; 9 | { 10 | no warnings qw(qw); # the commas 11 | @ARGS = ( 12 | [qw(graph graphs 0)], 13 | [qw(vertex vertices 1 a a,b a a,b,c)], 14 | [qw(edge edges 2 a-a a-a,b-b a-a,b a-a,b-b,c-c a-a,b-b,b-c,c-c)], 15 | ); 16 | } 17 | for my $t (@ARGS) { 18 | my ($what, $whats, $arity, $g1, $g2, $g3, $g4, $g5) = @$t; 19 | my @args = ('a') x $arity; 20 | my @args2 = ('b') x $arity; 21 | my @args3 = ('c') x $arity; 22 | my @anti_args = ("x") x $arity; 23 | my ( 24 | $add_e, $del_e, $has_e, 25 | $add_w, $has_w, $get_w, $set_w, $del_w, 26 | $names, $values, 27 | $has, $get, $set, $del, 28 | $hass, $gets, $sets, $dels, 29 | ) = map sprintf($_, $what), qw( 30 | add_%s delete_%s has_%s 31 | add_weighted_%s has_%s_weight get_%s_weight set_%s_weight delete_%s_weight 32 | get_%s_attribute_names get_%s_attribute_values 33 | has_%s_attribute get_%s_attribute set_%s_attribute delete_%s_attribute 34 | has_%s_attributes get_%s_attributes set_%s_attributes delete_%s_attributes 35 | ); 36 | my ( 37 | $list_e, $add_ws, 38 | ) = map sprintf($_, $whats), qw( 39 | %s add_weighted_%s 40 | ); 41 | 42 | my $g_d = Graph::Directed->new; 43 | my $g_u = Graph::Undirected->new; 44 | $_->add_edge(1, 1) for $g_d, $g_u; 45 | $g_d->$set((1) x $arity, 'color', 'electric blue'); 46 | $g_u->$set((1) x $arity, 'color', 'firetruck red'); 47 | is $g_d, '1-1'; 48 | is $g_u, '1=1'; 49 | 50 | my $g = Graph->new; 51 | 52 | $g->$add_e(@args) if $arity; 53 | 54 | ok( !$g->$hass(@args) ) for 1..2; 55 | 56 | ok( $g->$set(@args, "color", "red") ); 57 | 58 | ok( $g->$has(@args, "color") ) for 1..2; 59 | 60 | ok( $g->$hass(@args) ) for 1..2; 61 | 62 | is( $g->$get(@args, "color"), "red" ) for 1..2; 63 | 64 | is( $g->$get(@args, "colour"), undef ) for 1..2; 65 | 66 | ok( $g->$set(@args, "color", "green") ); 67 | 68 | ok( $g->$hass(@args) ) for 1..2; 69 | 70 | is( $g->$get(@args, "color"), "green" ) for 1..2; 71 | 72 | is_deeply $g->$gets(@args), { color => "green" }; 73 | is_deeply [ $g->$gets(@anti_args) ], [ undef ] if $arity; 74 | is_deeply [ $g->$names(@args) ], [ 'color' ]; 75 | is_deeply [ $g->$values(@args) ], [ 'green' ]; 76 | 77 | ok( $g->$set(@args, "taste", "rhubarb") ); 78 | 79 | ok( $g->$hass(@args) ) for 1..2; 80 | 81 | is( $g->$get(@args, "taste"), "rhubarb" ) for 1..2; 82 | is( $g->$get(@args, "color"), "green" ); 83 | is( $g->$get(@args, "taste"), "rhubarb" ); 84 | 85 | is_deeply $g->$gets(@args), { color => "green", taste => "rhubarb" }; 86 | is_deeply [ sort $g->$names(@args) ], [ qw(color taste) ]; 87 | is_deeply [ sort $g->$values(@args) ], [ qw(green rhubarb) ]; 88 | 89 | ok( $g->$del(@args, "color" ) ); 90 | 91 | ok( !$g->$has(@args, "color" ) ); 92 | ok( $g->$hass(@args) ); 93 | is( $g->$get(@args, "taste"), "rhubarb" ); 94 | 95 | ok( $g->$dels(@args) ); 96 | ok( !$g->$hass(@args) ); 97 | is( $g->$get(@args, "taste"), undef ); 98 | 99 | ok( !$g->$del(@args, "taste" ) ); 100 | ok( !$g->$dels(@args) ); 101 | 102 | is_deeply $g->$gets(@args), undef; 103 | is_deeply [ $g->$names(@args) ], []; 104 | is_deeply [ $g->$values(@args) ], []; 105 | 106 | ok($g->$sets(@args, { 'color' => 'pearl', 'weight' => 'heavy' })); 107 | is_deeply $g->$gets(@args), { 'color' => 'pearl', 'weight' => 'heavy' }; 108 | 109 | next if !$arity; 110 | 111 | ok( $g->$del_e(@args2) ); 112 | is $g, $g1; 113 | ok(!$g->$has_e(@args2)); 114 | $g->$add_w(@args2, 42); 115 | is $g, $g2; 116 | ok( $g->$has_e(@args2)); 117 | is( $g->$get_w(@args2), 42 ); 118 | is( $g->$get(@args2, 'weight'), 42 ); 119 | 120 | is( $g->$list_e, 2 ); 121 | 122 | ok( $g->$del_e(@args2) ); 123 | ok( $g->$del_e(@args3) ); 124 | is $g, $g3; 125 | $g->$add_ws(@args2, 43, @args3, 44); 126 | is $g, $g4; 127 | is( $g->$get_w(@args2), 43 ); 128 | is( $g->$get_w(@args3), 44 ); 129 | 130 | is( $g->$list_e, 3 ); 131 | 132 | if ($arity > 1) { 133 | ok( $g->$del_e(@args2) ); 134 | ok( $g->$del_e($args2[1], $args3[0]) ); 135 | $g->add_weighted_path($args2[0], 45, $args2[1], 46, $args3[0]); 136 | is $g, $g5; 137 | is( $g->get_edge_weight(@args2), 45 ); 138 | is( $g->get_edge_weight($args2[1], $args3[0]), 46 ); 139 | 140 | is( $g->$list_e, 4 ); 141 | } 142 | 143 | ok( $g->$set_w(@args, 42)); 144 | is( $g->$get_w(@args), 42); 145 | ok( $g->$has_w(@args)); 146 | ok(!$g->$has_w(@anti_args)); 147 | ok( $g->$del_w(@args)); 148 | ok(!$g->$has_w(@args)); 149 | is( $g->$get_w(@args), undef); 150 | } 151 | -------------------------------------------------------------------------------- /t/51_multivertex_attributes.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 62; 3 | 4 | use Graph; 5 | my $g = Graph->new(multivertexed => 1); 6 | 7 | $g->add_vertex_by_id("a", "hot"); 8 | 9 | ok( !$g->has_vertex_attributes_by_id("a", "hot") ); 10 | ok( !$g->has_vertex_attributes_by_id("a", "hot") ); 11 | 12 | ok( $g->set_vertex_attribute_by_id("a", "hot", "color", "red") ); 13 | 14 | ok( $g->has_vertex_attribute_by_id("a", "hot", "color") ); 15 | ok( $g->has_vertex_attribute_by_id("a", "hot", "color") ); 16 | 17 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 18 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 19 | 20 | is( $g->get_vertex_attribute_by_id("a", "hot", "color"), "red" ); 21 | is( $g->get_vertex_attribute_by_id("a", "hot", "color"), "red" ); 22 | 23 | is( $g->get_vertex_attribute_by_id("a", "hot", "colour"), undef ); 24 | is( $g->get_vertex_attribute_by_id("a", "hot", "colour"), undef ); 25 | 26 | ok( $g->set_vertex_attribute_by_id("a", "hot", "color", "green") ); 27 | 28 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 29 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 30 | 31 | is( $g->get_vertex_attribute_by_id("a", "hot", "color"), "green" ); 32 | is( $g->get_vertex_attribute_by_id("a", "hot", "color"), "green" ); 33 | 34 | my $attr = $g->get_vertex_attributes_by_id("a", "hot"); 35 | my @name = $g->get_vertex_attribute_names_by_id("a", "hot"); 36 | my @val = $g->get_vertex_attribute_values_by_id("a", "hot"); 37 | 38 | is_deeply $attr, { color => "green" }; 39 | is_deeply \@name, [ "color" ]; 40 | is_deeply \@val, [ "green" ]; 41 | 42 | ok( $g->set_vertex_attribute_by_id("a", "hot", "taste", "rhubarb") ); 43 | 44 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 45 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 46 | 47 | is( $g->get_vertex_attribute_by_id("a", "hot", "taste"), "rhubarb" ); 48 | is( $g->get_vertex_attribute_by_id("a", "hot", "taste"), "rhubarb" ); 49 | 50 | is( $g->get_vertex_attribute_by_id("a", "hot", "color"), "green" ); 51 | is( $g->get_vertex_attribute_by_id("a", "hot", "taste"), "rhubarb" ); 52 | 53 | $attr = $g->get_vertex_attributes_by_id("a", "hot"); 54 | @name = sort $g->get_vertex_attribute_names_by_id("a", "hot"); 55 | @val = sort $g->get_vertex_attribute_values_by_id("a", "hot"); 56 | 57 | is_deeply $attr, { color => "green", taste => "rhubarb" }; 58 | is_deeply \@name, [ "color", "taste" ]; 59 | is_deeply \@val, [ "green", "rhubarb" ]; 60 | is_deeply(($g->as_hashes)[0], { a => { hot => { color => "green", taste => "rhubarb" } } }); 61 | 62 | ok( $g->delete_vertex_attribute_by_id("a", "hot", "color" ) ); 63 | 64 | ok( !$g->has_vertex_attribute_by_id("a", "hot", "color" ) ); 65 | ok( $g->has_vertex_attributes_by_id("a", "hot") ); 66 | is( $g->get_vertex_attribute_by_id("a", "hot", "taste"), "rhubarb" ); 67 | 68 | ok( $g->delete_vertex_attributes_by_id("a", "hot") ); 69 | ok( !$g->has_vertex_attributes_by_id("a", "hot") ); 70 | is( $g->get_vertex_attribute_by_id("a", "hot", "taste"), undef ); 71 | 72 | ok( !$g->delete_vertex_attribute_by_id("a", "hot", "taste" ) ); 73 | ok( $g->delete_vertex_attributes_by_id("a", "hot") ); 74 | 75 | $attr = $g->get_vertex_attributes_by_id("a", "hot"); 76 | @name = $g->get_vertex_attribute_names_by_id("a", "hot"); 77 | @val = $g->get_vertex_attribute_values_by_id("a", "hot"); 78 | 79 | is_deeply $attr, undef; 80 | is_deeply \@name, []; 81 | is_deeply \@val, []; 82 | 83 | is( $g->vertices, 1 ); # Deleting attributes does not delete vertex 84 | 85 | $g->add_weighted_vertex_by_id("b", "cool", 42); 86 | 87 | ok( $g->has_vertex_by_id("b", "cool") ); 88 | is( $g->get_vertex_weight_by_id("b", "cool"), 42 ); 89 | 90 | is( $g->vertices, 2 ); 91 | 92 | $g->add_weighted_vertices_by_id("b", 43, "c", 44, "cool"); 93 | is( $g->get_vertex_weight_by_id("b", "cool"), 43 ); 94 | is( $g->get_vertex_weight_by_id("c", "cool" ), 44 ); 95 | 96 | is( $g->vertices, 3 ); 97 | 98 | ok($g->set_vertex_attributes_by_id('a', 'hot', 99 | { 'color' => 'pearl', 'weight' => 'heavy' })); 100 | $attr = $g->get_vertex_attributes_by_id('a', 'hot'); 101 | is_deeply $attr, { color => "pearl", weight => 'heavy' }; 102 | 103 | ok( $g->set_vertex_weight_by_id("a", "hot", 42)); 104 | is( $g->get_vertex_weight_by_id("a", "hot"), 42); 105 | ok( $g->has_vertex_weight_by_id("a", "hot")); 106 | ok(!$g->has_vertex_weight_by_id("x", "hot")); 107 | ok( $g->delete_vertex_weight_by_id("a", "hot")); 108 | ok(!$g->has_vertex_weight_by_id("a", "hot")); 109 | is( $g->get_vertex_weight_by_id("a", "hot"), undef); 110 | 111 | ok( $g->set_vertex_attribute_by_id("a", 0, "zero", "absolute") ); 112 | my $got = [ sort $g->vertices ]; 113 | is_deeply($got, [qw(a a b c)]) or diag explain $got; 114 | 115 | my $h = Graph->new(multivertexed => 1); 116 | 117 | eval { $h->set_vertex_attribute("foo", "color", "gold") }; 118 | like($@, qr/expected non-multivertexed/); 119 | 120 | $h->ingest($g); 121 | $got = ($h->as_hashes)[0]; 122 | is_deeply($got, { 123 | a => { hot => { color => 'pearl' }, 0 => { "zero" => "absolute" } }, 124 | b => { cool => { weight => 43 } }, 125 | c => { cool => { weight => 44 } } 126 | }) or diag explain $got; 127 | -------------------------------------------------------------------------------- /t/56_neighbourhood.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph; 5 | my $g0 = Graph->new; 6 | my $g1 = Graph->new(undirected => 1); 7 | 8 | my @E = ([1=>1], [1=>2], [1=>3], [2=>4], [5=>4]); 9 | $g0->add_edge(@$_) for @E; 10 | $g1->add_edge(@$_) for @E; 11 | $g0->add_vertex(6); $g1->add_vertex(6); 12 | 13 | is $g0, "1-1,1-2,1-3,2-4,5-4,6"; 14 | is $g1, "1=1,1=2,1=3,2=4,4=5,6"; 15 | 16 | my %methods = ( 17 | neighbours => [ 18 | [ [1], "1 2 3", "1 2 3" ], 19 | [ [2], "1 4", "1 4" ], 20 | [ [3], "1", "1" ], 21 | [ [4], "2 5", "2 5" ], 22 | [ [5], "4", "4" ], 23 | [ [6], "", "" ], 24 | ], 25 | neighbours_by_radius => [ 26 | [ [1, 1], "1 2 3", "1 2 3" ], 27 | [ [2, 1], "1 4", "1 4" ], 28 | [ [3, 1], "1", "1" ], 29 | [ [4, 1], "2 5", "2 5" ], 30 | [ [5, 2], "2 4", "2 4" ], 31 | [ [6, 1], "", "" ], 32 | ], 33 | is_successorless_vertex => [ 34 | [ [1], "", "" ], 35 | [ [2], "", "" ], 36 | [ [3], 1, "" ], 37 | [ [4], 1, "" ], 38 | [ [5], "", "" ], 39 | [ [6], 1, 1 ], 40 | ], 41 | is_successorful_vertex => [ 42 | [ [1], 1, 1 ], 43 | [ [2], 1, 1 ], 44 | [ [3], "", 1 ], 45 | [ [4], "", 1 ], 46 | [ [5], 1, 1 ], 47 | [ [6], "", "" ], 48 | ], 49 | is_predecessorless_vertex => [ 50 | [ [1], "", "" ], 51 | [ [2], "", "" ], 52 | [ [3], "", "" ], 53 | [ [4], "", "" ], 54 | [ [5], 1, "" ], 55 | [ [6], 1, 1 ], 56 | ], 57 | is_predecessorful_vertex => [ 58 | [ [1], 1, 1 ], 59 | [ [2], 1, 1 ], 60 | [ [3], 1, 1 ], 61 | [ [4], 1, 1 ], 62 | [ [5], "", 1 ], 63 | [ [6], "", "" ], 64 | ], 65 | successorless_vertices => [ 66 | [ [], "3 4 6", "6" ], 67 | ], 68 | successorful_vertices => [ 69 | [ [], "1 2 5", "1 2 3 4 5" ], 70 | ], 71 | predecessorless_vertices => [ 72 | [ [], "5 6", "6" ], 73 | ], 74 | predecessorful_vertices => [ 75 | [ [], "1 2 3 4", "1 2 3 4 5" ], 76 | ], 77 | ); 78 | for my $m (sort keys %methods) { 79 | for my $t ( @{ $methods{$m} } ) { 80 | my ($args, $expected0, $expected1) = @$t; 81 | my $got0_count = scalar $g0->$m(@$args); 82 | my $expected0_count = @{[split ' ', $expected0]}; 83 | is $got0_count+0, $expected0_count, "right number for scalar context $m"; 84 | is( "@{[sort $g0->$m(@$args)]}", $expected0, "directed $m (@$args)" ); 85 | is( "@{[sort $g1->$m(@$args)]}", $expected1, "undirected $m (@$args)" ); 86 | } 87 | } 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/57_degree.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 50; 3 | 4 | use Graph; 5 | my $g0 = Graph->new; 6 | my $g1 = Graph->new(undirected => 1); 7 | 8 | $g0->add_edge(1=>1); $g1->add_edge(1=>1); 9 | $g0->add_edge(1=>2); $g1->add_edge(1=>2); 10 | $g0->add_edge(1=>3); $g1->add_edge(1=>3); 11 | $g0->add_edge(2=>4); $g1->add_edge(2=>4); 12 | $g0->add_edge(5=>4); $g1->add_edge(5=>4); 13 | $g0->add_vertex(6); $g1->add_vertex(6); 14 | 15 | is( $g0->in_degree(1), 1 ); 16 | is( $g0->in_degree(2), 1 ); 17 | is( $g0->in_degree(3), 1 ); 18 | is( $g0->in_degree(4), 2 ); 19 | is( $g0->in_degree(5), 0 ); 20 | is( $g0->in_degree(6), 0 ); 21 | 22 | is( $g0->out_degree(1), 3 ); 23 | is( $g0->out_degree(2), 1 ); 24 | is( $g0->out_degree(3), 0 ); 25 | is( $g0->out_degree(4), 0 ); 26 | is( $g0->out_degree(5), 1 ); 27 | is( $g0->out_degree(6), 0 ); 28 | 29 | is( $g0->degree(1), -2 ); 30 | is( $g0->degree(2), 0 ); 31 | is( $g0->degree(3), 1 ); 32 | is( $g0->degree(4), 2 ); 33 | is( $g0->degree(5), -1 ); 34 | is( $g0->degree(6), 0 ); 35 | 36 | is( $g0->vertex_degree(1), $g0->degree(1) ); 37 | is( $g0->vertex_degree(2), $g0->degree(2) ); 38 | is( $g0->vertex_degree(3), $g0->degree(3) ); 39 | is( $g0->vertex_degree(4), $g0->degree(4) ); 40 | is( $g0->vertex_degree(5), $g0->degree(5) ); 41 | is( $g0->vertex_degree(6), $g0->degree(6) ); 42 | 43 | is( $g1->in_degree(1), 4 ); 44 | is( $g1->in_degree(2), 2 ); 45 | is( $g1->in_degree(3), 1 ); 46 | is( $g1->in_degree(4), 2 ); 47 | is( $g1->in_degree(5), 1 ); 48 | is( $g1->in_degree(6), 0 ); 49 | 50 | is( $g1->out_degree(1), 4 ); 51 | is( $g1->out_degree(2), 2 ); 52 | is( $g1->out_degree(3), 1 ); 53 | is( $g1->out_degree(4), 2 ); 54 | is( $g1->out_degree(5), 1 ); 55 | is( $g1->out_degree(6), 0 ); 56 | 57 | is( $g1->degree(1), 4 ); 58 | is( $g1->degree(2), 2 ); 59 | is( $g1->degree(3), 1 ); 60 | is( $g1->degree(4), 2 ); 61 | is( $g1->degree(5), 1 ); 62 | is( $g1->degree(6), 0 ); 63 | 64 | is( $g1->vertex_degree(1), $g1->degree(1) ); 65 | is( $g1->vertex_degree(2), $g1->degree(2) ); 66 | is( $g1->vertex_degree(3), $g1->degree(3) ); 67 | is( $g1->vertex_degree(4), $g1->degree(4) ); 68 | is( $g1->vertex_degree(5), $g1->degree(5) ); 69 | is( $g1->vertex_degree(6), $g1->degree(6) ); 70 | 71 | is( $g0->degree, 0 ); 72 | is( $g1->degree, 10 ); 73 | 74 | -------------------------------------------------------------------------------- /t/58_connections.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 24; 3 | 4 | use Graph; 5 | my $g0 = Graph->new; 6 | my $g1 = Graph->new(undirected => 1); 7 | 8 | my @E = ([1=>1], [1=>2], [1=>3], [2=>4], [5=>4]); 9 | $g0->add_edge(@$_) for @E; 10 | $g1->add_edge(@$_) for @E; 11 | $g0->add_vertex(6); $g1->add_vertex(6); 12 | 13 | test_graphs($g0, $g1, { 14 | sink_vertices => [ [ [], "3 4", "" ] ], 15 | source_vertices => [ [ [], "5", "" ] ], 16 | isolated_vertices => [ [ [], "6", "6" ] ], 17 | interior_vertices => [ [ [], "2", "1 2 3 4 5" ] ], 18 | exterior_vertices => [ [ [], "3 4 5 6", "6" ] ], 19 | self_loop_vertices => [ [ [], "1", "1" ] ], 20 | }); 21 | 22 | sub test_graphs { 23 | my ($g0, $g1, $methods) = @_; 24 | for my $m (sort keys %$methods) { 25 | for my $t ( @{ $methods->{$m} } ) { 26 | my ($args, $expected0, $expected1) = @$t; 27 | is( "@{[sort $g0->$m(@$args)]}", $expected0, "directed $m (@$args)" ); 28 | is( "@{[sort $g1->$m(@$args)]}", $expected1, "undirected $m (@$args)" ); 29 | } 30 | } 31 | } 32 | 33 | use Graph::Directed; 34 | use Graph::Undirected; 35 | 36 | $g0 = Graph::Directed->new; 37 | $g1 = Graph::Undirected->new; 38 | 39 | my @P = ([qw(a b d)], [qw(b e)], [qw(a c f f)], [qw(g h)], [qw(i i)], [qw(k k l)]); 40 | $g0->add_path(@$_) for @P; 41 | $g1->add_path(@$_) for @P; 42 | $_->add_vertex(qw(j)) for $g0, $g1; 43 | 44 | test_graphs($g0, $g1, { 45 | sink_vertices => [ [ [], "d e h l", "" ] ], 46 | source_vertices => [ [ [], "a g", "" ] ], 47 | isolated_vertices => [ [ [], "j", "j" ] ], 48 | interior_vertices => [ [ [], "b c", "a b c d e f g h k l" ] ], 49 | exterior_vertices => [ [ [], "a d e g h j l", "j" ] ], 50 | self_loop_vertices => [ [ [], "f i k", "f i k" ] ], 51 | }); 52 | -------------------------------------------------------------------------------- /t/60_bfs.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 93; 3 | 4 | use Graph::Directed; 5 | use Graph::Undirected; 6 | use Graph::Traversal::BFS; 7 | 8 | my $g0 = Graph::Undirected->new; 9 | my $g1 = Graph::Directed->new; 10 | my $g2 = Graph::Undirected->new; # cyclic 11 | my $g3 = Graph::Undirected->new; # unconnetced 12 | my $g4 = Graph::Directed->new; # cyclic 13 | my $g5 = Graph::Directed->new; # cyclic 14 | 15 | $g0->add_path(qw(a b c)); 16 | $g0->add_path(qw(a b d)); 17 | $g0->add_path(qw(a e f)); 18 | 19 | $g1->add_path(qw(a b c)); 20 | $g1->add_path(qw(a b d)); 21 | $g1->add_path(qw(a e f)); 22 | 23 | $g2->add_cycle(qw(a b c)); 24 | 25 | $g3->add_path(qw(a b c)); 26 | $g3->add_path(qw(d e f)); 27 | 28 | $g4->add_cycle(qw(a)); 29 | 30 | $g5->add_cycle(qw(a b c)); 31 | 32 | sub simple { 33 | my $g = shift; 34 | my @v = $g->vertices; 35 | is(@_, @v, "vertices"); 36 | my %v; $v{$_} ++ for @_; 37 | is(scalar(grep { ($v{$_} || 0) != 1 } @v), 0, "... once"); 38 | } 39 | 40 | { 41 | my $t = Graph::Traversal::BFS->new($g0); 42 | 43 | is($t->unseen, $g0->vertices, "fresh traversal"); 44 | is($t->seen, 0); 45 | is($t->seeing, 0); 46 | 47 | my @t0 = $t->preorder; 48 | my @t1 = $t->postorder; 49 | my @t2 = $t->bfs; 50 | 51 | simple($g0, @t0); 52 | simple($g0, @t1); 53 | simple($g0, @t2); 54 | 55 | is($t->graph, $g0, "graph"); 56 | } 57 | 58 | { 59 | my @pre; 60 | my @post; 61 | my $t = Graph::Traversal::BFS->new($g0, 62 | pre => sub { push @pre, $_[0] }, 63 | post => sub { push @post, $_[0] }, 64 | next_alphabetic => 1); 65 | my @t0 = $t->preorder; 66 | my @t1 = $t->postorder; 67 | my @t2 = $t->bfs; 68 | 69 | simple($g1, @t0); 70 | simple($g1, @t1); 71 | simple($g1, @t2); 72 | 73 | is("@pre", "a b e c d f", "pre"); 74 | is("@post", "a b e c d f", "post"); 75 | is("@t0", "@pre", "t0"); 76 | is("@t1", "@post", "t1"); 77 | is("@t2", "@post", "t2"); 78 | 79 | is($t->unseen, 0, "unseen none"); 80 | is($t->seen, 6, "seen all"); 81 | is($t->seeing, 0, "seeing none"); 82 | is("@{[sort $t->seen]}", "a b c d e f", "seen all"); 83 | is("@{[$t->roots]}", "a", "roots"); 84 | } 85 | 86 | { 87 | my @pre; 88 | my @post; 89 | my $t = Graph::Traversal::BFS->new($g1, 90 | pre => sub { push @pre, $_[0] }, 91 | post => sub { push @post, $_[0] }, 92 | next_alphabetic => 1, 93 | first_root => 'b'); 94 | my @t0 = $t->preorder; 95 | my @t1 = $t->postorder; 96 | my @t2 = $t->bfs; 97 | 98 | simple($g1, @t0); 99 | simple($g1, @t1); 100 | simple($g1, @t2); 101 | 102 | is("@pre", "b c d a e f", "pre"); 103 | is("@post", "b c d a e f", "post"); 104 | is("@t0", "@pre", "t0"); 105 | is("@t1", "@post", "t1"); 106 | is("@t2", "@post", "t2"); 107 | 108 | is($t->unseen, 0, "unseen none"); 109 | is($t->seen, 6, "seen all"); 110 | is($t->seeing, 0, "seeing none"); 111 | is("@{[sort $t->seen]}", "a b c d e f", "seen all"); 112 | is("@{[$t->roots]}", "b a", "roots"); 113 | } 114 | 115 | { 116 | my $t0 = Graph::Traversal::BFS->new($g0, next_alphabetic => 1); 117 | is($t0->next, "a", "scalar next"); 118 | $t0->terminate; 119 | is($t0->next, undef, "terminate"); 120 | $t0->reset; 121 | is($t0->next, "a", "after reset scalar next"); 122 | } 123 | 124 | { 125 | my @pre; 126 | my @post; 127 | my $t = Graph::Traversal::BFS->new($g2, 128 | pre => sub { push @pre, $_[0] }, 129 | post => sub { push @post, $_[0] }, 130 | next_alphabetic => 1); 131 | my @t0 = $t->preorder; 132 | my @t1 = $t->postorder; 133 | my @t2 = $t->postorder; 134 | 135 | simple($g2, @t0); 136 | simple($g2, @t1); 137 | simple($g2, @t2); 138 | 139 | is("@pre", "a b c", "pre"); 140 | is("@post", "a b c", "post"); 141 | is("@t0", "@pre", "t0"); 142 | is("@t1", "@post", "t1"); 143 | is("@t2", "@post", "t2"); 144 | 145 | is($t->unseen, 0, "unseen none"); 146 | is($t->seen, 3, "seen all"); 147 | is($t->seeing, 0, "seeing none"); 148 | is("@{[sort $t->seen]}", "a b c", "seen all"); 149 | is("@{[$t->roots]}", "a", "roots"); 150 | } 151 | 152 | { 153 | my @pre; 154 | my @post; 155 | my $t = Graph::Traversal::BFS->new($g3, 156 | pre => sub { push @pre, $_[0] }, 157 | post => sub { push @post, $_[0] }, 158 | next_alphabetic => 1); 159 | my @t0 = $t->preorder; 160 | my @t1 = $t->postorder; 161 | my @t2 = $t->postorder; 162 | 163 | simple($g3, @t0); 164 | simple($g3, @t1); 165 | simple($g3, @t2); 166 | 167 | is("@pre", "a b c d e f", "pre"); 168 | is("@post", "a b c d e f", "post"); 169 | is("@t0", "@pre", "t0"); 170 | is("@t1", "@post", "t1"); 171 | is("@t2", "@post", "t2"); 172 | 173 | is($t->unseen, 0, "unseen none"); 174 | is($t->seen, 6, "seen all"); 175 | is($t->seeing, 0, "seeing none"); 176 | is("@{[sort $t->seen]}", "a b c d e f", "seen all"); 177 | is("@{[$t->roots]}", "a d", "roots"); 178 | } 179 | 180 | { 181 | my @pre; 182 | my @post; 183 | my $t = Graph::Traversal::BFS->new($g0, 184 | first_root => 'a', 185 | pre => sub { push @pre, $_[0] }, 186 | post => sub { push @post, $_[0] }, 187 | next_successor => sub { shift; (reverse sort keys %{ $_[0] })[0] }); 188 | my @t0 = $t->preorder; 189 | my @t1 = $t->postorder; 190 | my @t2 = $t->bfs; 191 | 192 | simple($g1, @t0); 193 | simple($g1, @t1); 194 | simple($g1, @t2); 195 | 196 | is("@pre", "a e b f d c", "pre"); 197 | is("@post", "a e b f d c", "post"); 198 | is("@t0", "@pre", "t0"); 199 | is("@t1", "@post", "t1"); 200 | is("@t2", "@post", "t2"); 201 | 202 | is($t->unseen, 0, "unseen none"); 203 | is($t->seen, 6, "seen all"); 204 | is($t->seeing, 0, "seeing none"); 205 | is("@{[sort $t->seen]}", "a b c d e f", "seen all"); 206 | is("@{[$t->roots]}", "a", "roots"); 207 | } 208 | -------------------------------------------------------------------------------- /t/61_connected.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 264; 3 | 4 | my %undirected_map = map +($_ => $_), qw( 5 | is_connected 6 | connected_components 7 | connected_component_by_vertex 8 | connected_component_by_index 9 | same_connected_components 10 | connected_graph 11 | ); 12 | my %directed_map = map { (my $v=$_)=~s/connected/weakly_$&/;($_=>$v) } keys %undirected_map; 13 | my %mapping = ('Graph::Undirected' => \%undirected_map, 'Graph::Directed', \%directed_map); 14 | 15 | use Graph::Undirected; 16 | use Graph::Directed; 17 | 18 | test_graph(@$_) for ( 19 | ['Graph::Undirected', {}], 20 | ['Graph::Undirected', {unionfind => 1}], 21 | ['Graph::Undirected', {unionfind => 1, multiedged => 1}], 22 | ['Graph::Directed', {}], 23 | ); 24 | 25 | sub test_graph { 26 | my ($class, $args) = @_; 27 | my $label = "$class {".join(',', map "$_=>$args->{$_}", sort keys %$args)."}"; 28 | my $g0 = $class->new(%$args); 29 | my $methmap = $mapping{$class}; 30 | ok(!$g0->${ \$methmap->{is_connected} }); 31 | is( $g0->${ \$methmap->{connected_components} }, 0); 32 | is( $g0->${ \$methmap->{connected_component_by_vertex} }('a'), undef); 33 | is( $g0->${ \$methmap->{connected_component_by_index} }(0), undef ); 34 | ok(!$g0->${ \$methmap->{same_connected_components} }('a', 'b')); 35 | is($g0->${ \$methmap->{connected_graph} }, ''); 36 | 37 | $g0->add_vertex('a'); 38 | 39 | ok( $g0->${ \$methmap->{is_connected} }); 40 | is( $g0->${ \$methmap->{connected_components} }(), 1); 41 | isnt($g0->${ \$methmap->{connected_component_by_vertex} }('a'), undef); 42 | is( "@{[ $g0->${ \$methmap->{connected_component_by_index} }(0) ]}", 'a' ); 43 | ok(!$g0->${ \$methmap->{same_connected_components} }('a', 'b')); 44 | is($g0->${ \$methmap->{connected_graph} }, 'a'); 45 | 46 | $g0->add_vertex('b'); 47 | 48 | ok(!$g0->${ \$methmap->{is_connected} }, $label); 49 | is( $g0->${ \$methmap->{connected_components} }(), 2, $label); 50 | isnt($g0->${ \$methmap->{connected_component_by_vertex} }($_), undef, $label) for qw(a b); 51 | isnt $g0->${ \$methmap->{connected_component_by_vertex} }('a'), 52 | $g0->${ \$methmap->{connected_component_by_vertex} }('b'), $label; 53 | my @c0 = map [ $g0->${ \$methmap->{connected_component_by_index} }(0) ], (1..3); 54 | is( @$_, 1, $label ) for @c0; 55 | is( "@{$c0[0]}", "@{$c0[$_]}", $label ) for 1, 2; 56 | my @c1 = map [ $g0->${ \$methmap->{connected_component_by_index} }(1) ], (1..3); 57 | is( @$_, 1, $label ) for @c1; 58 | is( "@{$c1[0]}", "@{$c1[$_]}", $label ) for 1, 2; 59 | isnt( "@{$c0[0]}", "@{$c1[0]}", $label ); 60 | ok( ("@{$c0[0]}" eq "a" && "@{$c1[0]}" eq "b") || 61 | ("@{$c0[0]}" eq "b" && "@{$c1[0]}" eq "a"), $label ); 62 | ok(!$g0->${ \$methmap->{same_connected_components} }('a', 'b'), $label); 63 | is($g0->${ \$methmap->{connected_graph} }, 'a,b', $label); 64 | 65 | $g0->add_edge(qw(a b)); 66 | 67 | ok( $g0->${ \$methmap->{is_connected} }); 68 | is( $g0->${ \$methmap->{connected_components} }(), 1); 69 | isnt($g0->${ \$methmap->{connected_component_by_vertex} }($_), undef) for qw(a b); 70 | is($g0->${ \$methmap->{connected_component_by_vertex} }('a'), $g0->${ \$methmap->{connected_component_by_vertex} }('b')); 71 | @c0 = map [ $g0->${ \$methmap->{connected_component_by_index} }(0) ], (1..3); 72 | is( @$_, 2 ) for @c0; 73 | is( "@{$c0[0]}", "@{$c0[$_]}", $label ) for 1, 2; 74 | @c1 = map [ $g0->${ \$methmap->{connected_component_by_index} }(1) ], (1..3); 75 | is( @$_, 0, $label ) for @c1; 76 | is( "@{[ sort @{$c0[0]} ]}", "a b", $label ); 77 | ok( $g0->${ \$methmap->{same_connected_components} }('a', 'b')); 78 | is($g0->${ \$methmap->{connected_graph} }, 'a+b'); 79 | 80 | $g0->add_edge(qw(c d)); 81 | 82 | ok(!$g0->${ \$methmap->{is_connected} }); 83 | is( $g0->${ \$methmap->{connected_components} }(), 2); 84 | isnt($g0->${ \$methmap->{connected_component_by_vertex} }($_), undef) for qw(a b c d); 85 | is($g0->${ \$methmap->{connected_component_by_vertex} }($_->[0]), $g0->${ \$methmap->{connected_component_by_vertex} }($_->[1]), $label) for [qw(a b)], [qw(c d)]; 86 | isnt($g0->${ \$methmap->{connected_component_by_vertex} }('a'), $g0->${ \$methmap->{connected_component_by_vertex} }('d'), $label); 87 | ok( $g0->${ \$methmap->{same_connected_components} }(@$_), $label) for [qw(a b)], [qw(c d)]; 88 | ok(!$g0->${ \$methmap->{same_connected_components} }('a', 'c'), $label); 89 | my $g0c = $g0->${ \$methmap->{connected_graph} }; 90 | is($g0c, 'a+b,c+d'); 91 | is("@{[sort @{ $g0c->get_vertex_attribute('a+b', 'subvertices') }]}", "a b"); 92 | is("@{[sort @{ $g0c->get_vertex_attribute('c+d', 'subvertices') }]}", "c d"); 93 | is($g0c->get_vertex_attribute('b+a', 'subvertices'), undef); 94 | } 95 | 96 | my $g4 = Graph::Directed->new; 97 | 98 | eval { $g4->is_connected }; 99 | like($@, qr/Graph::is_connected: expected undirected graph, got directed/); 100 | 101 | eval { $g4->connected_components }; 102 | like($@, qr/Graph::connected_components: expected undirected graph, got directed/); 103 | 104 | eval { $g4->connected_component_by_vertex }; 105 | like($@, qr/Graph::connected_component_by_vertex: expected undirected graph, got directed/); 106 | 107 | eval { $g4->connected_component_by_index }; 108 | like($@, qr/Graph::connected_component_by_index: expected undirected graph, got directed/); 109 | 110 | eval { $g4->same_connected_components }; 111 | like($@, qr/Graph::same_connected_components: expected undirected graph, got directed/); 112 | 113 | eval { $g4->connected_graph }; 114 | like($@, qr/Graph::connected_graph: expected undirected graph, got directed/); 115 | 116 | my $g5 = Graph::Undirected->new; 117 | 118 | eval { $g5->is_weakly_connected }; 119 | like($@, qr/Graph::is_weakly_connected: expected directed graph, got undirected/); 120 | 121 | eval { $g5->weakly_connected_components }; 122 | like($@, qr/Graph::weakly_connected_components: expected directed graph, got undirected/); 123 | 124 | eval { $g5->weakly_connected_component_by_vertex }; 125 | like($@, qr/Graph::weakly_connected_component_by_vertex: expected directed graph, got undirected/); 126 | 127 | eval { $g5->weakly_connected_component_by_index }; 128 | like($@, qr/Graph::weakly_connected_component_by_index: expected directed graph, got undirected/); 129 | 130 | eval { $g5->same_weakly_connected_components }; 131 | like($@, qr/Graph::same_weakly_connected_components: expected directed graph, got undirected/); 132 | 133 | eval { $g5->weakly_connected_graph }; 134 | like($@, qr/Graph::weakly_connected_graph: expected directed graph, got undirected/); 135 | -------------------------------------------------------------------------------- /t/63_scc.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 56; 3 | 4 | use Graph; 5 | use Graph::Undirected; 6 | 7 | my $g0 = Graph->new; 8 | 9 | $g0->add_cycle(qw(a b)); 10 | $g0->add_edge(qw(b c)); 11 | 12 | my @c0 = $g0->strongly_connected_components; 13 | 14 | is(@c0, 2); 15 | @c0 = sort { @$a <=> @$b } @c0; 16 | is("@{$c0[0]}", 'c'); 17 | is("@{[sort @{$c0[1]}]}", 'a b'); 18 | 19 | is($g0->strongly_connected_graph, "a+b-c"); 20 | 21 | ok(!$g0->is_strongly_connected); 22 | 23 | my $g1 = Graph->new; 24 | 25 | $g1->add_path(qw(f f b a c b)); 26 | $g1->add_path(qw(c e d e g h g)); 27 | $g1->add_path(qw(f d)); 28 | 29 | my @c1 = $g1->strongly_connected_components; 30 | 31 | is(@c1, 4); 32 | @c1 = sort { @$a <=> @$b } @c1; 33 | is("@{[sort @{$c1[0]}]}", 'f'); 34 | is("@{[sort @{$c1[1]}]}", 'd e'); 35 | is("@{[sort @{$c1[2]}]}", 'g h'); 36 | is("@{[sort @{$c1[3]}]}", 'a b c'); 37 | 38 | my $g1s = $g1->strongly_connected_graph; 39 | 40 | is($g1s, "a+b+c-d+e,d+e-g+h,f-a+b+c,f-d+e"); 41 | 42 | is("@{[sort @{$g1s->get_vertex_attribute('a+b+c', 'subvertices')}]}", 43 | "a b c"); 44 | is("@{[sort @{$g1s->get_vertex_attribute('d+e', 'subvertices')}]}", 45 | "d e"); 46 | is("@{[sort @{$g1s->get_vertex_attribute('f', 'subvertices')}]}", 47 | "f"); 48 | is("@{[sort @{$g1s->get_vertex_attribute('g+h', 'subvertices')}]}", 49 | "g h"); 50 | is($g1s->get_vertex_attribute('h+g', 'subvertices'), undef); 51 | 52 | ok(!$g1->is_strongly_connected); 53 | 54 | my $g2 = Graph->new; 55 | 56 | $g2->add_cycle(qw(a b c)); 57 | $g2->add_cycle(qw(a d e)); 58 | 59 | my @c2 = $g2->strongly_connected_components; 60 | 61 | is(@c2, 1); 62 | @c2 = sort { @$a <=> @$b } @c2; 63 | is("@{[sort @{$c2[0]}]}", 'a b c d e'); 64 | 65 | is($g2->strongly_connected_graph, "a+b+c+d+e"); 66 | 67 | ok($g2->is_strongly_connected); 68 | 69 | my $g3 = Graph->new; 70 | 71 | $g3->add_path(qw(a b c)); 72 | $g3->add_vertices(qw(d e f)); 73 | 74 | my @c3 = $g3->strongly_connected_components; 75 | 76 | is(@c3, 6); 77 | @c3 = sort { @$a <=> @$b || "@$a" cmp "@$b" } @c3; 78 | is("@{[sort @{$c3[0]}]}", 'a'); 79 | is("@{[sort @{$c3[1]}]}", 'b'); 80 | is("@{[sort @{$c3[2]}]}", 'c'); 81 | is("@{[sort @{$c3[3]}]}", 'd'); 82 | is("@{[sort @{$c3[4]}]}", 'e'); 83 | is("@{[sort @{$c3[5]}]}", 'f'); 84 | 85 | is($g3->strongly_connected_graph, "a-b,b-c,d,e,f"); 86 | 87 | ok(!$g3->is_strongly_connected); 88 | 89 | $g3->add_cycle('d', 'a'); 90 | $g3->add_cycle('e', 'f'); 91 | 92 | is($g3->strongly_connected_graph(super_component => 93 | sub { my @v = sort @_; 94 | "(" . join("|", @v) . ")" } ), 95 | "(a|d)-(b),(b)-(c),(e|f)"); 96 | 97 | eval { $g3->strongly_connected_graph(foobar => 1) }; 98 | like($@, qr/Graph::strongly_connected_graph: Unknown option: 'foobar' /); 99 | 100 | # Example from Sedgewick Algorithms in C Third Edition 19.1 Figure 19.8 (p 150) 101 | my $g4 = Graph->new; 102 | $g4->add_edges([ 0, 1], [ 0, 5], [0, 6]); 103 | $g4->add_edges([ 2, 0], [ 2, 3]); 104 | $g4->add_edges([ 3, 2], [ 3, 5]); 105 | $g4->add_edges([ 4, 2], [ 4, 3], [4, 11]); 106 | $g4->add_edges([ 5, 4]); 107 | $g4->add_edges([ 6, 4], [ 6, 9]); 108 | $g4->add_edges([ 7, 6], [ 7, 8]); 109 | $g4->add_edges([ 8, 7], [ 8, 9]); 110 | $g4->add_edges([ 9, 10], [ 9, 11]); 111 | $g4->add_edges([10, 12]); 112 | $g4->add_edges([11, 12]); 113 | $g4->add_edges([12, 9]); 114 | my @g4s = sort { $a->[0] <=> $b->[0] } map { [sort { $a <=> $b} @$_] } $g4->strongly_connected_components; 115 | is(@g4s, 4); 116 | is("@{$g4s[0]}", "0 2 3 4 5 6"); 117 | is("@{$g4s[1]}", "1"); 118 | is("@{$g4s[2]}", "7 8"); 119 | is("@{$g4s[3]}", "9 10 11 12"); 120 | 121 | ok( $g4->same_strongly_connected_components('0', '2')); 122 | ok( $g4->same_strongly_connected_components('0', '6')); 123 | ok(!$g4->same_strongly_connected_components('0', '1')); 124 | ok( $g4->same_strongly_connected_components('7', '8')); 125 | ok( $g4->same_strongly_connected_components('9', '10')); 126 | ok( $g4->same_strongly_connected_components('9', '12')); 127 | ok(!$g4->same_strongly_connected_components('0', '7')); 128 | ok(!$g4->same_strongly_connected_components('0', '9')); 129 | 130 | is( $g4->strongly_connected_component_by_vertex('0'), 131 | $g4->strongly_connected_component_by_vertex('2')); 132 | 133 | isnt($g4->strongly_connected_component_by_vertex('0'), 134 | $g4->strongly_connected_component_by_vertex('1')); 135 | 136 | my @s = $g4->strongly_connected_components(); 137 | is( "@{[ sort $g4->strongly_connected_component_by_index(0) ]}", 138 | "@{[ sort @{ $s[0] } ]}" ); 139 | is( "@{[ sort $g4->strongly_connected_component_by_index(1) ]}", 140 | "@{[ sort @{ $s[1] } ]}" ); 141 | is( "@{[ sort $g4->strongly_connected_component_by_index(2) ]}", 142 | "@{[ sort @{ $s[2] } ]}" ); 143 | is( "@{[ sort $g4->strongly_connected_component_by_index(3) ]}", 144 | "@{[ sort @{ $s[3] } ]}" ); 145 | is( $g4->strongly_connected_component_by_index(4), 146 | undef ); 147 | 148 | my $g5 = Graph::Undirected->new; 149 | 150 | eval { $g5->strongly_connected_components }; 151 | like($@, qr/Graph::strongly_connected_components: expected directed graph, got undirected/); 152 | 153 | eval { $g5->strongly_connected_component_by_vertex }; 154 | like($@, qr/Graph::strongly_connected_component_by_vertex: expected directed graph, got undirected/); 155 | 156 | eval { $g5->strongly_connected_component_by_index }; 157 | like($@, qr/Graph::strongly_connected_component_by_index: expected directed graph, got undirected/); 158 | 159 | { 160 | # http://rt.cpan.org/NoAuth/Bug.html?id=1193 161 | use Graph::Directed; 162 | 163 | my $graph = new Graph::Directed; 164 | $graph->add_vertex("a"); 165 | $graph->add_vertex("b"); 166 | $graph->add_vertex("c"); 167 | $graph->add_edge("a","c"); 168 | $graph->add_edge("b","c"); 169 | $graph->add_edge("c","a"); 170 | my @cc = $graph->strongly_connected_components; 171 | is(@cc, 2); 172 | } 173 | -------------------------------------------------------------------------------- /t/64_mst.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 22; 3 | 4 | use Graph::Undirected; 5 | use Graph::Directed; 6 | 7 | my $g0 = Graph::Undirected->new; 8 | 9 | $g0->add_weighted_edge(qw(a b 1)); 10 | $g0->add_weighted_edge(qw(a c 2)); 11 | $g0->add_weighted_edge(qw(a d 1)); 12 | $g0->add_weighted_edge(qw(b d 2)); 13 | $g0->add_weighted_edge(qw(b e 2)); 14 | $g0->add_weighted_edge(qw(c d 2)); 15 | $g0->add_weighted_edge(qw(c f 1)); 16 | $g0->add_weighted_edge(qw(d e 1)); 17 | $g0->add_weighted_edge(qw(d f 1)); 18 | $g0->add_weighted_edge(qw(d g 2)); 19 | $g0->add_weighted_edge(qw(e g 1)); 20 | 21 | my $g1 = $g0->deep_copy; 22 | 23 | my $g0t = $g0->MST_Kruskal; 24 | 25 | ok($g0t->is_undirected); 26 | is($g0t->vertices, $g0->vertices); 27 | is($g0t->edges, $g0->vertices - 1); 28 | is($g0t, "a=b,a=d,c=f,d=e,d=f,e=g"); 29 | 30 | $g0->add_weighted_edge(qw(c f 3)); 31 | 32 | my $g0u = $g0->MST_Kruskal; 33 | 34 | ok($g0u->is_undirected); 35 | is($g0u->vertices, $g0->vertices); 36 | is($g0u->edges, $g0->vertices - 1); 37 | ok($g0u eq "a=b,a=c,a=d,d=e,d=f,e=g" || 38 | $g0u eq "a=b,a=d,c=d,d=e,d=f,e=g" || 39 | $g0u eq "a=b,a=c,c=f,d=e,e=g"); 40 | 41 | my $g1t = $g1->MST_Prim; 42 | 43 | ok($g1t->is_undirected); 44 | is($g1t->vertices, $g0->vertices); 45 | is($g1t->edges, $g0->vertices - 1); 46 | ok($g1t eq "a=b,a=d,c=f,d=e,d=f,e=g" || 47 | $g1t eq "a=b,a=c,a=d,d=e,d=f,e=g"); 48 | 49 | my $g1u = $g1->MST_Prim(first_root => "g"); 50 | 51 | ok($g1u->is_undirected); 52 | is($g1u->vertices, $g0->vertices); 53 | is($g1u->edges, $g0->vertices - 1); 54 | ok($g1u eq "a=b,a=d,c=f,d=e,d=f,e=g" || 55 | $g1u eq "a=b,a=c,a=d,d=e,d=f,e=g"); 56 | 57 | $g1->add_weighted_edge(qw(c f 3)); 58 | 59 | my $g1v = $g1->MST_Kruskal; 60 | 61 | ok($g1v->is_undirected); 62 | is($g1v->vertices, $g1->vertices); 63 | is($g1v->edges, $g1->vertices - 1); 64 | ok($g1v eq "a=b,a=c,a=d,d=e,d=f,e=g" || 65 | $g1v eq "a=b,a=d,c=d,d=e,d=f,e=g"); 66 | 67 | my $g2 = Graph::Directed->new; 68 | 69 | eval { $g2->MST_Kruskal }; 70 | like($@, qr/Graph::MST_Kruskal: expected undirected graph, got directed, /); 71 | 72 | eval { $g2->MST_Prim }; 73 | like($@, qr/Graph::MST_Prim: expected undirected graph, got directed, /); 74 | 75 | -------------------------------------------------------------------------------- /t/66_simple.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 96; 3 | 4 | use Graph; 5 | 6 | my ($g0, $g1, $g2, $g3, $g4, $g5, $g6, $g7, 7 | $g8, $g9, $ga, $gb, $gc, $gd, $ge, $gf); 8 | 9 | $g0 = Graph->new; 10 | $g1 = Graph->new(countedged => 1); 11 | $g2 = Graph->new->add_edge(qw(a a)); 12 | $g3 = Graph->new(countedged => 1)->add_edge(qw(a a)); 13 | $g4 = Graph->new->add_edge(qw(a b)); 14 | $g5 = Graph->new(countedged => 1)->add_edge(qw(a b)); 15 | $g6 = Graph->new->add_edge(qw(a a))->add_edge(qw(a b)); 16 | $g7 = Graph->new(countedged => 1)->add_edge(qw(a a))->add_edge(qw(a b)); 17 | $g8 = Graph->new->add_edge(qw(a b)); 18 | $g9 = Graph->new(countedged => 1)->add_edge(qw(a b)); 19 | $ga = Graph->new->add_edge(qw(a a))->add_edge(qw(a b)); 20 | $gb = Graph->new(countedged => 1)->add_edge(qw(a a))->add_edge(qw(a b)); 21 | $gc = Graph->new->add_edge(qw(a b))->add_edge(qw(a b)); 22 | $gd = Graph->new(countedged => 1)->add_edge(qw(a b))->add_edge(qw(a b)); 23 | $ge = Graph->new->add_edge(qw(a a))->add_edge(qw(a b))->add_edge(qw(a b)); 24 | $gf = Graph->new(countedged => 1)->add_edge(qw(a a))->add_edge(qw(a b))->add_edge(qw(a b)); 25 | 26 | ok( $g0->is_simple_graph); 27 | ok(!$g0->is_pseudo_graph); 28 | ok(!$g0->is_multi_graph); 29 | 30 | ok( $g1->is_simple_graph); 31 | ok(!$g1->is_pseudo_graph); 32 | ok(!$g1->is_multi_graph); 33 | 34 | ok( $g2->is_simple_graph); 35 | ok( $g2->is_pseudo_graph); # a a 36 | ok(!$g2->is_multi_graph); 37 | 38 | ok( $g3->is_simple_graph); 39 | ok( $g3->is_pseudo_graph); # a a 40 | ok(!$g3->is_multi_graph); 41 | 42 | ok( $g4->is_simple_graph); 43 | ok(!$g4->is_pseudo_graph); 44 | ok(!$g4->is_multi_graph); 45 | 46 | ok( $g5->is_simple_graph); 47 | ok(!$g5->is_pseudo_graph); 48 | ok(!$g5->is_multi_graph); 49 | 50 | ok( $g6->is_simple_graph); 51 | ok( $g6->is_pseudo_graph); # a a once 52 | ok(!$g6->is_multi_graph); 53 | 54 | ok( $g7->is_simple_graph); 55 | ok( $g7->is_pseudo_graph); # a a once 56 | ok(!$g7->is_multi_graph); 57 | 58 | ok( $g8->is_simple_graph); 59 | ok(!$g8->is_pseudo_graph); 60 | ok(!$g8->is_multi_graph); 61 | 62 | ok( $g9->is_simple_graph); 63 | ok(!$g9->is_pseudo_graph); 64 | ok(!$g9->is_multi_graph); 65 | 66 | ok( $ga->is_simple_graph); 67 | ok( $ga->is_pseudo_graph); # a a once 68 | ok(!$ga->is_multi_graph); 69 | 70 | ok( $gb->is_simple_graph); 71 | ok( $gb->is_pseudo_graph); # a a once 72 | ok(!$gb->is_multi_graph); 73 | 74 | ok( $gc->is_simple_graph); 75 | ok(!$gc->is_pseudo_graph); 76 | ok(!$gc->is_multi_graph); 77 | 78 | ok(!$gd->is_simple_graph); # a b twice 79 | ok( $gd->is_pseudo_graph); # a b twice 80 | ok( $gd->is_multi_graph); # a b twice 81 | 82 | ok( $ge->is_simple_graph); 83 | ok( $ge->is_pseudo_graph); # a a once 84 | ok(!$ge->is_multi_graph); 85 | 86 | ok(!$gf->is_simple_graph); 87 | ok( $gf->is_pseudo_graph); # a a once, a b twice 88 | ok(!$gf->is_multi_graph); # a a once, a b twice 89 | 90 | $g0 = Graph->new; 91 | $g1 = Graph->new(multiedged => 1); 92 | $g2 = Graph->new->add_edge(qw(a a)); 93 | $g3 = Graph->new(multiedged => 1)->add_edge(qw(a a)); 94 | $g4 = Graph->new->add_edge(qw(a b)); 95 | $g5 = Graph->new(multiedged => 1)->add_edge(qw(a b)); 96 | $g6 = Graph->new->add_edge(qw(a a))->add_edge(qw(a b)); 97 | $g7 = Graph->new(multiedged => 1)->add_edge(qw(a a))->add_edge(qw(a b)); 98 | $g8 = Graph->new->add_edge(qw(a b)); 99 | $g9 = Graph->new(multiedged => 1)->add_edge(qw(a b)); 100 | $ga = Graph->new->add_edge(qw(a a))->add_edge(qw(a b)); 101 | $gb = Graph->new(multiedged => 1)->add_edge(qw(a a))->add_edge(qw(a b)); 102 | $gc = Graph->new->add_edge(qw(a b))->add_edge(qw(a b)); 103 | $gd = Graph->new(multiedged => 1)->add_edge(qw(a b))->add_edge(qw(a b)); 104 | $ge = Graph->new->add_edge(qw(a a))->add_edge(qw(a b))->add_edge(qw(a b)); 105 | $gf = Graph->new(multiedged => 1)->add_edge(qw(a a))->add_edge(qw(a b))->add_edge(qw(a b)); 106 | 107 | ok( $g0->is_simple_graph); 108 | ok(!$g0->is_pseudo_graph); 109 | ok(!$g0->is_multi_graph); 110 | 111 | ok( $g1->is_simple_graph); 112 | ok(!$g1->is_pseudo_graph); 113 | ok(!$g1->is_multi_graph); 114 | 115 | ok( $g2->is_simple_graph); 116 | ok( $g2->is_pseudo_graph); # a a 117 | ok(!$g2->is_multi_graph); 118 | 119 | ok( $g3->is_simple_graph); 120 | ok( $g3->is_pseudo_graph); # a a 121 | ok(!$g3->is_multi_graph); 122 | 123 | ok( $g4->is_simple_graph); 124 | ok(!$g4->is_pseudo_graph); 125 | ok(!$g4->is_multi_graph); 126 | 127 | ok( $g5->is_simple_graph); 128 | ok(!$g5->is_pseudo_graph); 129 | ok(!$g5->is_multi_graph); 130 | 131 | ok( $g6->is_simple_graph); 132 | ok( $g6->is_pseudo_graph); # a a once 133 | ok(!$g6->is_multi_graph); 134 | 135 | ok( $g7->is_simple_graph); 136 | ok( $g7->is_pseudo_graph); # a a once 137 | ok(!$g7->is_multi_graph); 138 | 139 | ok( $g8->is_simple_graph); 140 | ok(!$g8->is_pseudo_graph); 141 | ok(!$g8->is_multi_graph); 142 | 143 | ok( $g9->is_simple_graph); 144 | ok(!$g9->is_pseudo_graph); 145 | ok(!$g9->is_multi_graph); 146 | 147 | ok( $ga->is_simple_graph); 148 | ok( $ga->is_pseudo_graph); # a a once 149 | ok(!$ga->is_multi_graph); 150 | 151 | ok( $gb->is_simple_graph); 152 | ok( $gb->is_pseudo_graph); # a a once 153 | ok(!$gb->is_multi_graph); 154 | 155 | ok( $gc->is_simple_graph); 156 | ok(!$gc->is_pseudo_graph); 157 | ok(!$gc->is_multi_graph); 158 | 159 | ok(!$gd->is_simple_graph); # a b twice 160 | ok( $gd->is_pseudo_graph); # a b twice 161 | ok( $gd->is_multi_graph); # a b twice 162 | 163 | ok( $ge->is_simple_graph); 164 | ok( $ge->is_pseudo_graph); # a a once 165 | ok(!$ge->is_multi_graph); 166 | 167 | ok(!$gf->is_simple_graph); 168 | ok( $gf->is_pseudo_graph); # a a once, a b twice 169 | ok(!$gf->is_multi_graph); # a a once, a b twice 170 | -------------------------------------------------------------------------------- /t/67_copy.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph::Directed; 5 | use Graph::Undirected; 6 | 7 | my ($g0, $g2, $g4) = map Graph::Directed->new, 1..3; 8 | my ($g1, $g3, $g5) = map Graph::Undirected->new, 1..3; 9 | 10 | $_->add_path(qw(a b c)) for $g0, $g1; 11 | $_->add_path(qw(d b e)) for $g0, $g1; 12 | 13 | $_->add_path(qw(c a b c d)) for $g2, $g3; 14 | 15 | $_->add_path(qw(b a b c)) for $g4, $g5; 16 | 17 | is $g0->copy, "a-b,b-c,b-e,d-b"; 18 | is $g1->copy, "a=b,b=c,b=d,b=e"; 19 | is $g2->copy, "a-b,b-c,c-a,c-d"; 20 | is $g3->copy, "a=b,a=c,b=c,c=d"; 21 | is $g4->copy, "a-b,b-a,b-c"; 22 | is $g5->copy, "a=b,b=c"; 23 | 24 | is $g0->undirected_copy, $g1; 25 | $g0->undirected_copy->delete_vertex('a'); 26 | is $g0->undirected_copy, $g1; 27 | is $g2->undirected_copy, $g3; 28 | is $g4->undirected_copy, $g5; 29 | 30 | is $g1->directed_copy, "a-b,b-a,b-c,b-d,b-e,c-b,d-b,e-b"; 31 | $g1->directed_copy->delete_vertex('a'); 32 | is $g1->directed_copy, "a-b,b-a,b-c,b-d,b-e,c-b,d-b,e-b"; 33 | is $g3->directed_copy, "a-b,a-c,b-a,b-c,c-a,c-b,c-d,d-c"; 34 | is $g5->directed_copy, "a-b,b-a,b-c,c-b"; 35 | 36 | is $g0->transpose, "b-a,b-d,c-b,e-b"; 37 | is $g1->transpose, "a=b,b=c,b=d,b=e"; 38 | is $g2->transpose, "a-c,b-a,c-b,d-c"; 39 | is $g3->transpose, "a=b,a=c,b=c,c=d"; 40 | is $g4->transpose, "a-b,b-a,c-b"; 41 | is $g5->transpose, "a=b,b=c"; 42 | 43 | $g0 = Graph::Directed->new(multivertexed=>1, multiedged=>1); 44 | $g1 = Graph::Undirected->new(multivertexed=>1, multiedged=>1); 45 | $_->add_path_by_id(qw(a b c), 'id') for $g0, $g1; 46 | $_->add_path_by_id(qw(d b e), 'id') for $g0, $g1; 47 | $_->set_vertex_attribute_by_id(qw(d 0 height 7)) for $g0, $g1; 48 | $_->set_edge_attribute_by_id(qw(d b id weight 5)) for $g0, $g1; 49 | is $g0, "a-b,b-c,b-e,d-b"; 50 | is $g1, "a=b,b=c,b=d,b=e"; 51 | my $expected = Graph::_deep_copy_best([$g1->as_hashes]); 52 | delete $expected->[0]{$_->[0]}{$_->[1]}{$_->[2]} for [qw(d 0 height)]; 53 | delete $expected->[1]{$_->[0]}{$_->[1]}{$_->[2]}{$_->[3]} for [qw(d b id weight)], [qw(b d id weight)]; 54 | is_deeply [$g0->undirected_copy->as_hashes], $expected, 'undirected_copy preserve multi' 55 | or diag 'got: ', explain([$g0->undirected_copy->as_hashes]), 56 | 'expected: ', explain($expected); 57 | is_deeply [$g0->undirected_copy_attributes->as_hashes], [$g1->as_hashes], 'undirected_copy_attributes' 58 | or diag 'got: ', explain([$g0->undirected_copy_attributes->as_hashes]), 59 | 'expected: ', explain([$g1->as_hashes]); 60 | $expected = Graph::_deep_copy_best([$g0->as_hashes]); 61 | $expected->[1]{$_->[0]}{$_->[1]}{id} = {} for [qw(b a)],[qw(b d)],[qw(c b)],[qw(e b)]; 62 | my $expected2 = Graph::_deep_copy_best($expected); 63 | $expected2->[1]{b}{d} = $expected2->[1]{d}{b}; 64 | is_deeply [$g1->directed_copy_attributes->as_hashes], $expected2, 'directed_copy_attributes' 65 | or diag 'got: ', explain([$g1->directed_copy_attributes->as_hashes]), 66 | 'expected: ', explain($expected2); 67 | delete $expected->[0]{$_->[0]}{$_->[1]}{$_->[2]} for [qw(d 0 height)]; 68 | delete $expected->[1]{$_->[0]}{$_->[1]}{$_->[2]}{$_->[3]} for [qw(d b id weight)]; 69 | is_deeply [$g1->directed_copy->as_hashes], $expected, 'directed_copy preserve multi' 70 | or diag 'got: ', explain([$g1->directed_copy->as_hashes]), 71 | 'expected: ', explain($expected); 72 | $expected = Graph::_deep_copy_best([$g0->as_hashes]); 73 | delete $expected->[0]{$_->[0]}{$_->[1]}{$_->[2]} for [qw(d 0 height)]; 74 | delete $expected->[1]{$_->[0]}{$_->[1]}{$_->[2]}{$_->[3]} for [qw(d b id weight)]; 75 | is_deeply [$g0->copy->as_hashes], $expected, 'copy of directed preserve multi' 76 | or diag 'got: ', explain([$g0->copy->as_hashes]), 77 | 'expected: ', explain($expected); 78 | $expected = Graph::_deep_copy_best([$g1->as_hashes]); 79 | delete $expected->[0]{$_->[0]}{$_->[1]}{$_->[2]} for [qw(d 0 height)]; 80 | delete $expected->[1]{$_->[0]}{$_->[1]}{$_->[2]}{$_->[3]} for [qw(d b id weight)], [qw(b d id weight)]; 81 | is_deeply [$g1->copy->as_hashes], $expected, 'copy of undirected preserve multi' 82 | or diag 'got: ', explain([$g1->copy->as_hashes]), 83 | 'expected: ', explain($expected); 84 | 85 | my $g6 = Graph->new; 86 | is($g6->complete->edges, 0); 87 | is($g6->complement->edges, 0); 88 | 89 | my $g7 = Graph::Directed->new(); 90 | $g7->add_edge(qw(a b)); 91 | $g7->add_edge(qw(a c)); 92 | is($g7, "a-b,a-c"); 93 | is($g7->complete, "a-b,a-c,b-a,b-c,c-a,c-b"); 94 | is($g7->complement, "b-a,b-c,c-a,c-b"); 95 | 96 | my $g8 = Graph::Undirected->new(); 97 | $g8->add_edge(qw(a b)); 98 | $g8->add_edge(qw(a c)); 99 | is($g8, "a=b,a=c"); 100 | is($g8->complete, "a=b,a=c,b=c"); 101 | is($g8->complement, "b=c,a"); 102 | 103 | my $g9 = Graph::Directed->new(countedged => 1); 104 | $g9->add_edge(qw(a b)); 105 | $g9->add_edge(qw(a c)); 106 | my $c9 = $g9->complete_graph; 107 | is $c9, "a-b,a-c,b-a,b-c,c-a,c-b"; 108 | for my $u (qw(a b c)) { 109 | for my $v (qw(a b c)) { 110 | next if $u eq $v; 111 | is($c9->get_edge_count($u, $v), 1); 112 | } 113 | } 114 | is $g9->complement_graph, "b-a,b-c,c-a,c-b"; 115 | 116 | my $g10 = Graph::Undirected->new(); 117 | $g10->add_edge(qw(a b)); 118 | is scalar($g10->vertices), 2; 119 | my $c10 = $g10->complement_graph; 120 | is scalar($c10->vertices), 2; 121 | is scalar($c10->edges), 0; 122 | 123 | { 124 | my $g = Graph->new; 125 | $g->set_graph_attribute('color' => 'deep_purple'); 126 | $g->set_graph_attribute('hunky' => sub { "hunky $_[0]" }); 127 | SKIP: { 128 | skip("no coderef Deparse", 2) unless $] >= 5.008; 129 | my $c = $g->deep_copy; 130 | is($c->get_graph_attribute('color'), 'deep_purple'); 131 | is($c->get_graph_attribute('hunky')->('dory'), 'hunky dory'); 132 | } 133 | } 134 | 135 | SKIP: { 136 | skip("no coderef Deparse", 1) unless $] >= 5.008; 137 | my $g = Graph->new; 138 | $g->set_graph_attribute('color' => sub { $_[0] ** 2 }); 139 | my $c = $g->deep_copy; 140 | is($c->get_graph_attribute('color')->(7), 49); 141 | } 142 | 143 | SKIP: { 144 | skip("no coderef Deparse", 1) unless $] >= 5.008; 145 | skip("no coderef Deparse with Storable", 1) 146 | unless Graph::_can_deep_copy_Storable(); 147 | require Storable; 148 | my $g = Graph->new; 149 | $g->set_graph_attribute('color' => sub { $_[0] ** 3 }); 150 | my $c = $g->_deep_copy_Storable; 151 | is($c->get_graph_attribute('color')->(2), 8); 152 | } 153 | 154 | SKIP: { 155 | skip("no coderef Deparse", 1) unless $] >= 5.008; 156 | my $g = Graph->new; 157 | $g->set_graph_attribute('color' => sub { $_[0] ** 4 }); 158 | my $c = $g->_deep_copy_DataDumper; 159 | is($c->get_graph_attribute('color')->(3), 81); 160 | } 161 | 162 | my $edges = [[{ name => 'A' }, { name => 'B' }]]; 163 | SKIP: { 164 | my $orig = Graph::Undirected->new(refvertexed=>1, edges=>$edges); 165 | for my $g ($orig, $orig->deep_copy) { 166 | is scalar $g->neighbours( $_ ), 1, 'still linked up' for $g->vertices; 167 | } 168 | } 169 | 170 | done_testing; 171 | -------------------------------------------------------------------------------- /t/71_spt.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph; 5 | use Graph::Directed; 6 | use Graph::Undirected; 7 | 8 | my $g = Graph::Directed->new; 9 | $g->add_weighted_path("b", 1, "f", 2, "c", 3, "d", 3, 10 | "f", 2, "g", 2, "e"); 11 | $g->add_weighted_edges("d", "e", 3, 12 | "g", "a", 3, 13 | "g", "f", 2, 14 | "b", "a", 3, 15 | "h", "b", 1, 16 | "h", "c", 1); 17 | 18 | my $sgb_d = $g->SPT_Dijkstra(first_root => "b"); 19 | is $sgb_d->get_graph_attribute('SPT_Dijkstra_root'), "b"; 20 | is( $sgb_d, "b-a,b-f,c-d,f-c,f-g,g-e" ); 21 | 22 | my $sgb_bf = $g->SPT_Bellman_Ford(first_root => "b"); 23 | is $sgb_bf->get_graph_attribute('SPT_Bellman_Ford_root'), "b"; 24 | is( $sgb_bf, "b-a,b-f,c-d,f-c,f-g,g-e" ); 25 | 26 | my $sgh_d = $g->SPT_Dijkstra(first_root => sub { "h" }); 27 | is $sgh_d->get_graph_attribute('SPT_Dijkstra_root'), "h"; 28 | is( $sgh_d, "b-a,b-f,c-d,f-g,g-e,h-b,h-c" ); 29 | 30 | my $sga_d = $g->SPT_Dijkstra(start => "a"); 31 | is $sga_d->get_graph_attribute('SPT_Dijkstra_root'), "a"; 32 | is( $sga_d, '' ); 33 | 34 | my $u = Graph::Undirected->new; 35 | $u->add_weighted_path("b", 1, "f", 36 | 2, "c", 37 | 3, "d", 38 | 3, "f", 39 | 2, "g", 40 | 2, "e"); 41 | $u->add_weighted_edges("d", "e", 3, 42 | "g", "a", 3, 43 | "g", "f", 2, 44 | "b", "a", 3, 45 | "h", "b", 1, 46 | "h", "c", 1); 47 | 48 | my $sub = $u->SPT_Dijkstra(first_root => "b"); 49 | is $sub->get_graph_attribute('SPT_Dijkstra_root'), "b"; 50 | is( $sub, "a=b,b=f,b=h,c=h,d=f,e=g,f=g" ); 51 | 52 | my $suh = $u->SPT_Dijkstra(first_root => "h"); 53 | is $suh->get_graph_attribute('SPT_Dijkstra_root'), "h"; 54 | is( $suh, "a=b,b=f,b=h,c=d,c=h,e=g,f=g" ); 55 | 56 | my $sua = $u->SPT_Dijkstra(first_root => "a"); 57 | is $sua->get_graph_attribute('SPT_Dijkstra_root'), "a"; 58 | ok( $sua eq "a=b,a=g,b=f,b=h,c=h,d=e,e=g" || 59 | $sua eq "a=b,a=g,b=f,b=h,c=h,d=f,e=g" || 60 | $sua eq "a=b,a=g,c=f,c=h,d=e,e=g,f=g" || 61 | $sua eq "a=b,a=g,c=f,c=h,d=f,e=g,f=g" ); 62 | 63 | # Sedgewick, Algorithms in C, Third Edition 64 | # Chapter 21, "Shortest Paths", Figure 21.10 (p 282) 65 | for my $is_multi (0,1) { 66 | my $g2 = Graph::Directed->new(multiedged=>$is_multi); 67 | my $awe = 'add_weighted_edge'.($is_multi ? '_by_id' : ''); 68 | my @id = $is_multi ? 'ID' : (); 69 | $g2->$awe(@$_[0,1], @id, $_->[2]) for [0,1,0.41], [1,2,0.51], [2,3,0.50], [4,3,0.36], 70 | [3,5,0.38], [3,0,0.45], [0,5,0.29], [5,4,0.21], [1,4,0.32], [4,2,0.32], 71 | [5,1,0.29]; 72 | 73 | my @s2_tests = ( 74 | [0,0,"0"], [0,1,"0 1"], [0,2,"0 5 4 2"], [0,3,"0 5 4 3"], 75 | [0,4,"0 5 4"], [0,5,"0 5"], 76 | [1,0,"1 4 3 0"], [1,1,"1"], [1,2,"1 2"], [1,3,"1 4 3"], 77 | [1,4,"1 4"], [1,5,"1 4 3 5"] 78 | ); 79 | is("@{[$g2->SP_Dijkstra(@$_[0,1])]}", $_->[2], "path @$_[0,1]") 80 | for @s2_tests; 81 | 82 | my $s2_di = $g2->SPT_Dijkstra(first_root => "0"); 83 | is( $s2_di, "0-1,0-5,4-2,4-3,5-4" ); 84 | is($s2_di->get_edge_attribute(@$_[0,1], 'weight'), $_->[2], "edge @$_[0,1]") 85 | for [0,1,0.41], [0,5,0.29], [5,4,0.50], [4,3,0.86], [4,2,0.82], 86 | [0,3,undef], [3,5,undef], [5,1,undef], [1,2,undef], [2,3,undef], 87 | [1,0,undef], [5,0,undef], [4,5,undef], [3,4,undef], [2,4,undef], 88 | [3,0,undef], [5,3,undef], [1,5,undef], [2,1,undef], [3,2,undef]; 89 | is($s2_di->get_vertex_attribute(@$_[0,1]), $_->[2], "vertex @$_[0,1]") 90 | for [0,'weight',undef], [1,'weight',0.41], [2,'weight',0.82], 91 | [3,'weight',0.86], [4,'weight',0.50], [5,'weight',0.29], 92 | [0,'p',undef], [1,'p',0], [2,'p',4], [3,'p',4], [4,'p',5], [5,'p',0]; 93 | 94 | is +($s2_di->get_edge_attribute_all(0, 1, 'weight'))[0], 0.41, "get_edge_attribute_all"; 95 | 96 | my $s2_bf = $g2->SPT_Bellman_Ford(first_root => "0"); 97 | is( $s2_bf, "0-1,0-5,4-2,4-3,5-4" ); 98 | is($s2_bf->get_edge_attribute(@$_[0,1], 'weight'), $_->[2], "edge @$_[0,1]") 99 | for [0,1,0.41], [0,5,0.29], [5,4,0.21], [4,3,0.36], [4,2,0.32], 100 | [0,3,undef], [3,5,undef], [5,1,undef], [1,2,undef], [2,3,undef], 101 | [1,0,undef], [5,0,undef], [4,5,undef], [3,4,undef], [2,4,undef], 102 | [3,0,undef], [5,3,undef], [1,5,undef], [2,1,undef], [3,2,undef]; 103 | is($s2_bf->get_vertex_attribute(@$_[0,1]), $_->[2], "vertex @$_[0,1]") 104 | for [0,'weight',undef], [1,'weight',0.41], [2,'weight',0.82], 105 | [3,'weight',0.86], [4,'weight',0.50], [5,'weight',0.29], 106 | [0,'p',undef], [1,'p',0], [2,'p',4], [3,'p',4], [4,'p',5], [5,'p',0]; 107 | is("@{[$g2->SP_Bellman_Ford(@$_[0,1])]}", $_->[2], "path @$_[0,1]") 108 | for @s2_tests; 109 | } 110 | 111 | my $g3 = Graph::Directed->new; 112 | $g3->add_weighted_path(qw(a 1 b 2 c 3 d -1 e 4 f)); 113 | 114 | my $s3_da = eval { $g3->SPT_Dijkstra(first_root => "a") }; 115 | like($@, qr/Graph::SPT_Dijkstra: edge d-e is negative \(-1\)/); 116 | is( $s3_da, undef ); 117 | 118 | my $s3_bf = eval { $g3->SPT_Bellman_Ford(first_root => "a") }; 119 | is($@, ''); 120 | is( $s3_bf, "a-b,b-c,c-d,d-e,e-f"); 121 | 122 | $g3->add_weighted_path(qw(b -2 a)); 123 | $s3_bf = eval { $g3->SPT_Bellman_Ford(first_root => "a") }; 124 | like($@, qr/Graph::SPT_Bellman_Ford: negative cycle exists/); 125 | is( $s3_bf, undef ); 126 | 127 | # http://rt.cpan.org/NoAuth/Bug.html?id=516 128 | my $g4 = new Graph::Undirected; 129 | $g4->add_weighted_edge("r1", "l1", 1); 130 | my $d4 = $g4->SSSP_Dijkstra("r1"); 131 | is($g4, "l1=r1"); 132 | is($d4, "l1=r1"); 133 | 134 | # Nathan Goodman 135 | my $g5 = Graph::Directed->new; 136 | $g5->add_path(qw(0 1 2)); 137 | my $sg5 = $g5->SPT_Dijkstra(first_root => "0"); 138 | is($sg5, "0-1,1-2"); 139 | 140 | { 141 | my $g = Graph::Directed->new(refvertexed => 1); 142 | $g->add_edge(qw(a b)); 143 | $g->add_edge(qw(a c)); 144 | $g->add_edge(qw(c d)); 145 | $g->add_edge(qw(c e)); 146 | $g->add_edge(qw(e f)); 147 | my $r = [1, 2, 3]; 148 | $g->add_edge('f', $r); 149 | 150 | my $s0 = $g->SPT_Dijkstra(first_root => 'a'); 151 | ok($s0->has_vertex('f')); 152 | my @e0 = $s0->successors('f'); 153 | is(@e0, 1); 154 | is_deeply($e0[0], $r); 155 | 156 | my $s1 = $g->SPT_Bellman_Ford(first_root => 'a'); 157 | ok($s1->has_vertex('f')); 158 | my @e1 = $s1->successors('f'); 159 | is(@e1, 1); 160 | is($e1[0], $r); 161 | } 162 | 163 | done_testing; 164 | -------------------------------------------------------------------------------- /t/73_diameter.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 84; 3 | 4 | use Graph; 5 | use Graph::Directed; 6 | use Graph::Undirected; 7 | 8 | my $g = Graph->new(undirected => 1); 9 | 10 | is($g->diameter, undef); 11 | is($g->radius, Graph::Infinity); 12 | is($g->shortest_path, undef); 13 | is_deeply([$g->shortest_path], []); 14 | is_deeply([sort $g->center_vertices], []); 15 | is($g->vertex_eccentricity('a'), Graph::Infinity); 16 | 17 | $g->add_vertex('a'); 18 | is($g->diameter, undef); 19 | is($g->radius, Graph::Infinity); 20 | is($g->shortest_path, undef); 21 | is_deeply([$g->shortest_path], []); 22 | is_deeply([sort $g->center_vertices], []); 23 | is($g->vertex_eccentricity('a'), Graph::Infinity); 24 | 25 | $g->add_vertex('b'); 26 | is($g->diameter, undef); 27 | is($g->radius, Graph::Infinity); 28 | is($g->shortest_path, undef); 29 | is_deeply([$g->shortest_path], []); 30 | is_deeply([sort $g->center_vertices], []); 31 | is($g->vertex_eccentricity('b'), Graph::Infinity); 32 | 33 | $g->add_edge(qw(e a)); 34 | $g->add_edge(qw(a r)); 35 | $g->add_edge(qw(r t)); 36 | $g->add_edge(qw(t h)); 37 | $g->add_edge(qw(h f)); 38 | $g->add_edge(qw(f r)); 39 | $g->add_edge(qw(r o)); 40 | $g->add_edge(qw(o m)); 41 | $g->add_edge(qw(m a)); 42 | $g->add_edge(qw(a b)); 43 | $g->add_edge(qw(b o)); 44 | $g->add_edge(qw(o v)); 45 | $g->add_edge(qw(v e)); 46 | 47 | is($g->diameter, 4); 48 | is($g->longest_path, 4); 49 | is($g->shortest_path, 1); 50 | is($g->longest_path(qw(a h)), 3); 51 | is($g->shortest_path(qw(a h)), 3); 52 | is($g->longest_path('a', undef), 3); 53 | is($g->shortest_path('a', undef), 1); 54 | is($g->longest_path(undef, 'h'), 4); 55 | is($g->shortest_path(undef, 'h'), 1); 56 | is($g->radius, 2); 57 | 58 | { 59 | my @c = sort $g->center_vertices; 60 | is(@c, 1); 61 | is("@c", "r"); 62 | } 63 | 64 | is($g->average_path_length(), 19 / 9); 65 | 66 | # Note that the below are just some of the possible paths, 67 | # for example other possible paths of length four are 68 | # a-r-t-h-e, a-m-o-r-t, b-o-v-e-a, ... 69 | # a-b: a-b : 1 70 | # a-e: a-r-o-v-e : 4 71 | # a-f: a-r-t-h-f : 4 72 | # a-h: a-r-t-h : 3 73 | # a-m: a-r-o-m : 3 74 | # a-o: a-r-o : 2 75 | # a-r: a-r : 1 76 | # a-t: a-r-t : 2 77 | # a-v: a-r-o-v : 3 78 | # 23 / 9 = 2.56 79 | is($g->average_path_length('a'), 15 / 9); 80 | is($g->average_path_length('b'), 20 / 9); 81 | is($g->average_path_length('c'), undef ); 82 | is($g->average_path_length('a', undef), 15 / 9); 83 | is($g->average_path_length('b', undef), 20 / 9); 84 | is($g->average_path_length(undef, 'a'), 15 / 9); 85 | is($g->average_path_length(undef, 'b'), 20 / 9); 86 | 87 | is($g->vertex_eccentricity('a'), 3); 88 | is($g->vertex_eccentricity('b'), 4); 89 | is($g->vertex_eccentricity('e'), 4); 90 | is($g->diameter, 4); 91 | is($g->radius, 2); 92 | 93 | { 94 | my @c; 95 | @c = sort $g->center_vertices; 96 | is(@c, 1); 97 | is("@c", "r"); 98 | @c = sort $g->center_vertices(1); 99 | is(@c, 5); 100 | is("@c", "a f o r t"); 101 | } 102 | 103 | sub gino { 104 | my $gi = $_[0]; 105 | my $m = (sort @$gi)[0]; 106 | for (my $i = 0; $i < @$gi && $gi->[0] ne $m; $i++) { 107 | push @$gi, shift @$gi; 108 | } 109 | return @$gi; 110 | } 111 | 112 | my $h = Graph->new(undirected => 1); 113 | 114 | $h->add_weighted_edge(qw(a b 2.3)); 115 | $h->add_weighted_edge(qw(a c 1.7)); 116 | 117 | is($h->longest_path, 4.0); 118 | is($h->shortest_path, 1.7); 119 | is($h->diameter, 4.0); 120 | is($h->radius, 2.3); 121 | 122 | my $i = Graph::Directed->new(undirected => 1); 123 | 124 | $i->add_edge(qw(k a)); 125 | $i->add_edge(qw(a l)); 126 | $i->add_edge(qw(l e)); 127 | $i->add_edge(qw(e v)); 128 | $i->add_edge(qw(v a)); 129 | $i->add_edge(qw(a l)); 130 | $i->add_edge(qw(l a)); 131 | $i->add_edge(qw(a n)); 132 | 133 | is($i->vertex_eccentricity('k'), 3); 134 | is($i->vertex_eccentricity('a'), 2); 135 | is($i->vertex_eccentricity('l'), 2); 136 | is($i->vertex_eccentricity('e'), 3); 137 | is($i->vertex_eccentricity('v'), 2); 138 | is($i->vertex_eccentricity('n'), 3); 139 | 140 | { 141 | my @c = sort $i->center_vertices; 142 | is(@c, 3); 143 | is("@c", "a l v"); 144 | } 145 | 146 | my $j = Graph::Undirected->new(undirected => 1); 147 | 148 | $j->add_edge(qw(k a)); 149 | $j->add_edge(qw(a l)); 150 | $j->add_edge(qw(l e)); 151 | $j->add_edge(qw(e v)); 152 | $j->add_edge(qw(v a)); 153 | $j->add_edge(qw(a l)); 154 | $j->add_edge(qw(l a)); 155 | $j->add_edge(qw(a n)); 156 | 157 | is($j->vertex_eccentricity('k'), 3); 158 | is($j->vertex_eccentricity('a'), 2); 159 | is($j->vertex_eccentricity('l'), 2); 160 | is($j->vertex_eccentricity('e'), 3); 161 | is($j->vertex_eccentricity('v'), 2); 162 | is($j->vertex_eccentricity('n'), 3); 163 | 164 | { 165 | my @c = sort $j->center_vertices; 166 | is(@c, 3); 167 | is("@c", "a l v"); 168 | } 169 | 170 | my $k = Graph::Undirected->new(undirected => 1); 171 | 172 | $k->add_edge(qw(s t)); 173 | $k->add_edge(qw(s a)); 174 | $k->add_edge(qw(s r)); 175 | 176 | is($k->vertex_eccentricity('s'), 1); 177 | is($k->vertex_eccentricity('t'), 2); 178 | is($k->vertex_eccentricity('a'), 2); 179 | is($k->vertex_eccentricity('r'), 2); 180 | 181 | { 182 | my @c = sort $k->center_vertices; 183 | is(@c, 1); 184 | is($c[0], 's'); 185 | } 186 | 187 | { 188 | # These tests inspired by Xiaoli Zheng. 189 | 190 | my $g = Graph::Directed->new(undirected => 1); 191 | 192 | is($g->diameter, undef); 193 | 194 | $g->add_edge('a', 'b'); 195 | is($g->diameter, 1); 196 | 197 | $g->add_edge('b', 'c'); 198 | is($g->diameter, 2); 199 | 200 | $g->add_edge('c', 'd'); 201 | is($g->diameter, 3); 202 | 203 | $g->add_edge('e', 'f'); 204 | is($g->diameter, 3); 205 | 206 | $g->add_edge('d', 'e'); 207 | is($g->diameter, 5); 208 | 209 | $g->add_edge('g', 'f'); 210 | is($g->diameter, 6); 211 | 212 | $g->delete_edge('c', 'b'); 213 | is($g->diameter, 4); 214 | 215 | $g->delete_edge('b', 'c'); 216 | is($g->diameter, 4); 217 | } 218 | 219 | { 220 | my $g = Graph->new(undirected => 1); 221 | 222 | $g->add_edge(qw(a b)); 223 | $g->add_edge(qw(c d)); 224 | 225 | is($g->vertex_eccentricity('a'), Graph::Infinity); 226 | } 227 | 228 | { 229 | my $g = Graph->new(undirected => 1); 230 | $g->add_path(1,2,3); 231 | is($g->average_path_length(1, 2), 1); 232 | } 233 | -------------------------------------------------------------------------------- /t/74_random.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 152; 3 | 4 | use Graph; 5 | 6 | my $g = Graph->new; 7 | 8 | is($g->random_vertex, undef); 9 | is($g->random_edge, undef); 10 | is($g->random_successor('a'), undef); 11 | is($g->random_predecessor('a'), undef); 12 | 13 | for my $v (0..9) { 14 | $g->add_edge($v, 2 * $v); 15 | } 16 | 17 | # print "g = $g\n"; 18 | 19 | my $N = 30; 20 | 21 | for (1..$N) { 22 | my $v = $g->random_vertex(); 23 | ok($v >= 0 && $v <= 18); 24 | } 25 | 26 | for (1..$N) { 27 | my $e = $g->random_edge(); 28 | my ($u, $v) = @$e; 29 | is($v, 2 * $u); 30 | } 31 | 32 | for (1..$N) { 33 | my ($u, $v); 34 | do { 35 | $u = $g->random_vertex(); 36 | $v = $g->random_successor($u); 37 | } until (defined $v); 38 | is($v, 2 * $u); 39 | } 40 | 41 | for (1..$N) { 42 | my ($u, $v); 43 | do { 44 | $v = $g->random_vertex(); 45 | $u = $g->random_predecessor($v); 46 | } until (defined $u); 47 | is($v, 2 * $u); 48 | } 49 | 50 | my $g0 = Graph->random_graph(vertices => [1..30], directed => 0); 51 | my $g1 = Graph->random_graph(vertices => 30, directed => 1); 52 | my $g2 = Graph->random_graph(vertices => 30, edges => 100); 53 | my $g3 = Graph->random_graph(vertices => 30, edges_fill => 0.1); 54 | 55 | is($g0->vertices, 30); 56 | is($g0->edges, 218); 57 | ok($g0->undirected); 58 | 59 | is($g1->vertices, 30); 60 | is($g1->edges, 435); 61 | ok($g1->directed); 62 | 63 | is($g2->vertices, 30); 64 | is($g2->edges, 100); 65 | 66 | is($g3->vertices, 30); 67 | is($g3->edges, 44); # int(30*29/2*0.1+0.5) 68 | 69 | my $g4a = Graph->random_graph(vertices => 10, random_seed => 1234); 70 | my $g4b = Graph->random_graph(vertices => 10, random_seed => 1234); 71 | my $g4c = Graph->random_graph(vertices => 10, random_seed => 1235); 72 | my $g4d = Graph->random_graph(vertices => 10, random_seed => 1235); 73 | my $g4e = Graph->random_graph(vertices => 10); 74 | 75 | SKIP: { 76 | # http://undeadly.org/cgi?action=article&sid=20141118170028 77 | # http://www.openbsd.org/plus58.html 78 | skip("openbsd rand() was undeterministic before Perl 5.20", 2) 79 | if $^O eq 'openbsd' && $] < 5.020; 80 | is ($g4a, $g4b); 81 | is ($g4c, $g4d); 82 | } 83 | isnt($g4a, $g4c); 84 | isnt($g4a, $g4d); 85 | isnt($g4a, $g4e); 86 | isnt($g4c, $g4e); 87 | 88 | my $g5 = Graph->random_graph(vertices => 10, 89 | edges => 10, 90 | random_edge => 91 | sub { 92 | my ($g, $u, $v, $p) = @_; 93 | # Create two "boxes" so that vertices 0..4 94 | # only have edges between each other, ditto 95 | # for vertices 5..9. 96 | my $a = $u < 5; 97 | my $b = $v < 5; 98 | return $a == $b ? $p : 0; 99 | }); 100 | 101 | for my $e ($g5->edges) { 102 | my ($u, $v) = @$e; 103 | my $a = $u < 5; 104 | my $b = $v < 5; 105 | is($a, $b, "u = $u, v = $v"); 106 | } 107 | 108 | my $g6 = Graph::random_graph(vertices => 10); 109 | 110 | isa_ok($g6, 'Graph'); 111 | is($g6->vertices, 10); 112 | 113 | -------------------------------------------------------------------------------- /t/75_attribute_array.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 9; 3 | package Array; 4 | use Graph::Attribute array => 0; 5 | sub new { bless [], shift } 6 | package main; 7 | my $o = Array->new(); 8 | ok(!$o->_g_has_attributes()); 9 | is(my $a = $o->_g_get_attributes(), undef); 10 | ok($o->_g_set_attributes({foo => 42})); 11 | ok($o->_g_has_attributes()); 12 | ok($a = $o->_g_get_attributes()); 13 | is($a->{foo}, 42); 14 | ok($o->_g_delete_attributes()); 15 | ok(!$o->_g_has_attributes()); 16 | is($a = $o->_g_get_attributes(), undef); 17 | -------------------------------------------------------------------------------- /t/76_attribute_hash.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 9; 2 | package Hash; 3 | use Graph::Attribute hash => _A; 4 | sub new { bless {}, shift } 5 | package main; 6 | use strict; use warnings; 7 | my $o = Hash->new(); 8 | ok(!$o->_g_has_attributes()); 9 | is(my $a = $o->_g_get_attributes(), undef); 10 | ok($o->_g_set_attributes({foo => 42})); 11 | ok($o->_g_has_attributes()); 12 | ok($a = $o->_g_get_attributes()); 13 | is($a->{foo}, 42); 14 | ok($o->_g_delete_attributes()); 15 | ok(!$o->_g_has_attributes()); 16 | is($a = $o->_g_get_attributes(), undef); 17 | -------------------------------------------------------------------------------- /t/77_adjacency.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 18; 3 | 4 | use Graph; 5 | use Graph::AdjacencyMatrix; 6 | 7 | my $g = Graph->new(vertices => [0..9]); 8 | 9 | $g->add_edge(qw(2 3)); 10 | 11 | my $m = Graph::AdjacencyMatrix->new($g); 12 | 13 | my $am = $m->adjacency_matrix; 14 | my $dm = $m->distance_matrix; 15 | my @V = $m->vertices; 16 | 17 | # use Data::Dumper; print Dumper($am); 18 | # use Data::Dumper; print Dumper($dm); 19 | # use Data::Dumper; print Dumper(\@V); 20 | 21 | is(@{$am->[0]}, 10); 22 | is($am->vertices, 10); 23 | is("@{[sort $am->vertices]}", "0 1 2 3 4 5 6 7 8 9"); 24 | 25 | is($dm, undef); 26 | 27 | is(@V, 10); 28 | is("@{[sort @V]}", "0 1 2 3 4 5 6 7 8 9"); 29 | 30 | ok( $m->is_adjacent(2, 3)); 31 | ok(!$m->is_adjacent(3, 2)); 32 | 33 | is( $m->distance(2, 3), undef); 34 | is( $m->distance(3, 2), undef); 35 | 36 | $g->add_weighted_edge(2, 3, 45); 37 | 38 | $m = Graph::AdjacencyMatrix->new($g, distance_matrix => 0); 39 | 40 | is( $m->distance(2, 3), undef); 41 | is( $m->distance(3, 2), undef); 42 | 43 | $m = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); 44 | 45 | is( $m->distance(2, 3), 45); 46 | is( $m->distance(3, 2), undef); 47 | 48 | # I for one welcome our new multiedged overlords! 49 | $g = Graph->new(vertices => [0..9], multiedged => 1); 50 | $g->set_edge_attribute_by_id(2, 3, 'c', 'other', 'hello'); 51 | $m = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); 52 | is_deeply $m->distance(2, 3), undef; 53 | is( $m->distance(3, 2), undef); 54 | $g->add_weighted_edge_by_id(2, 3, 'a', 45); 55 | $g->add_weighted_edge_by_id(2, 3, 'b', 47); 56 | $m = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); 57 | is_deeply $m->distance(2, 3), { a => 45, b => 47 }; 58 | is( $m->distance(3, 2), undef); 59 | -------------------------------------------------------------------------------- /t/78_expect.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 18; 3 | 4 | use Graph; 5 | 6 | my $g0 = Graph->new(directed => 1); 7 | my $g1 = Graph->new(directed => 0); 8 | my $g2 = Graph->new(directed => 1); 9 | 10 | $g0->add_edge('a', 'b'); 11 | $g1->add_edge('a', 'b'); 12 | $g2->add_edge('a', 'a'); 13 | 14 | eval { $g0->expect_undirected }; 15 | like($@, qr/expected undirected graph, got directed/); 16 | 17 | eval { $g1->expect_undirected }; 18 | is($@, ''); 19 | 20 | eval { $g0->expect_directed }; 21 | is($@, ''); 22 | 23 | eval { $g1->expect_directed }; 24 | like($@, qr/expected directed graph, got undirected/); 25 | 26 | eval { $g0->expect_acyclic }; 27 | is($@, ''); 28 | 29 | eval { $g1->expect_acyclic }; 30 | is($@, ''); 31 | 32 | eval { $g2->expect_acyclic }; 33 | like($@, qr/expected acyclic graph, got cyclic/); 34 | 35 | eval { $g0->expect_dag }; 36 | is($@, ''); 37 | 38 | eval { $g1->expect_dag }; 39 | like($@, qr/expected directed acyclic graph, got undirected/); 40 | 41 | eval { $g2->expect_dag }; 42 | like($@, qr/expected directed acyclic graph, got cyclic/); 43 | 44 | eval { Graph->random_graph(42) }; 45 | like($@, qr/Graph::random_graph: argument 'vertices' missing or undef/); 46 | 47 | eval { Graph->random_graph(vertices=>100) }; 48 | is($@, ''); 49 | 50 | eval { Graph->random_graph(42,43,44) }; 51 | like($@, qr/Graph::random_graph: argument 'vertices' missing or undef/); 52 | 53 | eval { Graph::_get_options() }; 54 | like($@, qr/internal error: should be called with only one array ref argument/); 55 | 56 | eval { Graph::_get_options(1) }; 57 | like($@, qr/internal error: should be called with only one array ref argument/); 58 | 59 | eval { Graph::_get_options([]) }; 60 | is($@, ''); 61 | 62 | eval { Graph::_get_options(12,34) }; 63 | like($@, qr/internal error: should be called with only one array ref argument/); 64 | 65 | my $uf = Graph->new(undirected => 1, unionfind => 1); 66 | $uf->add_edge(qw(a b)); 67 | eval { $uf->delete_edge("a") }; 68 | like($@, qr/Graph::delete_edge: expected non-unionfind graph/); 69 | -------------------------------------------------------------------------------- /t/79_unionfind.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph::UnionFind; 5 | 6 | my $uf = Graph::UnionFind->new; 7 | 8 | is_deeply [$uf->find('a')], [undef]; 9 | $uf->add('a'); 10 | is_deeply [$uf->find('a')], ['a']; 11 | $uf->add('b'); 12 | is_deeply [$uf->find('a')], ['a']; 13 | is_deeply [$uf->find('b')], ['b']; 14 | 15 | $uf->union(['a', 'b']); # http://rt.cpan.org/NoAuth/Bug.html?id=2627 16 | 17 | is_deeply [$uf->find('a')], ['b']; 18 | is_deeply [$uf->find('b')], ['b']; 19 | 20 | $uf->union(['c', 'd']); 21 | 22 | is_deeply [$uf->find('c')], ['d']; 23 | is_deeply [$uf->find('d')], ['d']; 24 | 25 | is_deeply [$uf->find('e')], [undef]; 26 | 27 | ok( $uf->same('a', 'b')); 28 | ok( $uf->same('b', 'a')); 29 | ok( $uf->same('c', 'd')); 30 | ok(!$uf->same('a', 'c')); 31 | 32 | $uf->union(['a', 'd']); 33 | ok( $uf->same('a', 'c')); 34 | 35 | ok(!$uf->same('c', 'e')); 36 | 37 | # rt.cpan.org #39805: UnionFind: Repeated adds clobbers graph component information 38 | my $graph = Graph::UnionFind->new; 39 | $graph->add('a'); 40 | $graph->union(['a','b']); 41 | 42 | ok($graph->same('a', 'b')); 43 | ok($graph->same('b', 'a')); 44 | 45 | $graph->add('a'); 46 | 47 | ok($graph->same('a', 'b')); 48 | ok($graph->same('b', 'a')); 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/80_isomorphic.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 31; 3 | 4 | use Graph; 5 | 6 | my $g0 = Graph->new; 7 | my $g1 = Graph->new; 8 | my $g2 = Graph->new; 9 | my $g3 = Graph->new; 10 | my $g4 = Graph->new; 11 | 12 | $g0->add_edges(qw(a b b c a d)); 13 | $g1->add_edges(qw(a b b c a d)); $g1->add_vertex('e'); 14 | $g2->add_edges(qw(a b b c a d b d)); 15 | $g3->add_edges(qw(a b b c b d)); 16 | $g4->add_edges(qw(a z a x x y)); 17 | 18 | ok( $g0->could_be_isomorphic($g0)); 19 | ok(!$g0->could_be_isomorphic($g1)); 20 | ok(!$g0->could_be_isomorphic($g2)); 21 | ok(!$g0->could_be_isomorphic($g3)); 22 | ok( $g0->could_be_isomorphic($g4)); 23 | 24 | ok(!$g1->could_be_isomorphic($g0)); 25 | ok( $g1->could_be_isomorphic($g1)); 26 | ok(!$g1->could_be_isomorphic($g2)); 27 | ok(!$g1->could_be_isomorphic($g3)); 28 | ok(!$g1->could_be_isomorphic($g4)); 29 | 30 | ok(!$g2->could_be_isomorphic($g0)); 31 | ok(!$g2->could_be_isomorphic($g1)); 32 | ok( $g2->could_be_isomorphic($g2)); 33 | ok(!$g2->could_be_isomorphic($g3)); 34 | ok(!$g2->could_be_isomorphic($g4)); 35 | 36 | ok(!$g3->could_be_isomorphic($g0)); 37 | ok(!$g3->could_be_isomorphic($g1)); 38 | ok(!$g3->could_be_isomorphic($g2)); 39 | ok( $g3->could_be_isomorphic($g3)); 40 | ok(!$g3->could_be_isomorphic($g4)); 41 | 42 | ok( $g4->could_be_isomorphic($g0)); 43 | ok(!$g4->could_be_isomorphic($g1)); 44 | ok(!$g4->could_be_isomorphic($g2)); 45 | ok(!$g4->could_be_isomorphic($g3)); 46 | ok( $g4->could_be_isomorphic($g4)); 47 | 48 | my $g5a = Graph->new; 49 | my $g5b = Graph->new; 50 | 51 | $g5a->add_edges(qw(a b a c a d)); 52 | $g5b->add_edges(qw(a x a y a z)); 53 | 54 | is($g5a->could_be_isomorphic($g5b), 6); # 3! 55 | is($g5b->could_be_isomorphic($g5a), 6); 56 | 57 | $g5a->add_edges(qw(e f e g)); 58 | $g5b->add_edges(qw(e t e u)); 59 | 60 | is($g5a->could_be_isomorphic($g5b), 120); # 5! 61 | is($g5b->could_be_isomorphic($g5a), 120); 62 | 63 | $g5a->add_edges(qw(h i h j h k)); 64 | $g5b->add_edges(qw(h i h j h k)); 65 | 66 | is($g5a->could_be_isomorphic($g5b), 80640); # 8! * 2! 67 | is($g5b->could_be_isomorphic($g5a), 80640); 68 | 69 | my $g6a = Graph->new; 70 | my $g6b = Graph->new; 71 | my $g6c = Graph->new; 72 | 73 | $g6a->add_vertices(qw(a b c d e f)); 74 | $g6a->add_edges(qw(a b b c b d)); 75 | 76 | $g6b->add_vertices(qw(a b c d e f)); 77 | $g6b->add_edges(qw(a b b c b e)); 78 | 79 | -------------------------------------------------------------------------------- /t/82_cycle.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Graph; 3 | use Test::More tests => 1; 4 | 5 | eval { require Devel::Cycle }; 6 | SKIP: { 7 | skip("no Devel::Cycle", 1) if $@; 8 | import Devel::Cycle; 9 | my $g = Graph->new; 10 | $g->add_edge(qw(a b)); 11 | $g->add_edge(qw(b c)); 12 | $g->add_edge(qw(c d)); 13 | $g->add_edge(qw(c e)); 14 | $g->add_cycle(qw(e f g)); # This is not a true cycle if weakrefs work. 15 | my $out = tie *STDOUT, 'FakeOut'; 16 | find_cycle($g); 17 | is($$out, undef); 18 | } 19 | 20 | package FakeOut; 21 | 22 | sub TIEHANDLE { 23 | bless(\(my $text), $_[0]); 24 | } 25 | 26 | sub PRINT { 27 | my $self = shift; 28 | $$self .= join('', @_); 29 | } 30 | 31 | -------------------------------------------------------------------------------- /t/83_bitmatrix.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 29; 3 | 4 | use Graph; 5 | use Graph::BitMatrix; 6 | 7 | my $g = Graph->new; 8 | 9 | $g->add_edge(qw(e a)); 10 | $g->add_edge(qw(a b)); 11 | $g->add_edge(qw(b c)); 12 | $g->add_edge(qw(b d)); 13 | $g->add_edge(qw(d d)); 14 | $g->delete_vertex('e'); 15 | 16 | my $m = Graph::BitMatrix->new($g); 17 | 18 | ok(!$m->get(qw(a a)) ); 19 | ok( $m->get(qw(a b)) ); 20 | ok(!$m->get(qw(a c)) ); 21 | ok(!$m->get(qw(a d)) ); 22 | 23 | ok(!$m->get(qw(b a)) ); 24 | ok(!$m->get(qw(b b)) ); 25 | ok( $m->get(qw(b c)) ); 26 | ok( $m->get(qw(b d)) ); 27 | 28 | ok(!$m->get(qw(c a)) ); 29 | ok(!$m->get(qw(c b)) ); 30 | ok(!$m->get(qw(c c)) ); 31 | ok(!$m->get(qw(c d)) ); 32 | 33 | ok(!$m->get(qw(d a)) ); 34 | ok(!$m->get(qw(d b)) ); 35 | ok(!$m->get(qw(d c)) ); 36 | ok( $m->get(qw(d d)) ); 37 | 38 | $m->set(qw(c c)); 39 | ok( $m->get(qw(c c)) ); 40 | 41 | $m->unset(qw(c c)); 42 | ok(!$m->get(qw(c c)) ); 43 | 44 | is("@{[$m->get_row(qw(a a b c d))]}", "0 1 0 0"); 45 | is("@{[$m->get_row(qw(b a b c d))]}", "0 0 1 1"); 46 | is("@{[$m->get_row(qw(c a b c d))]}", "0 0 0 0"); 47 | is("@{[$m->get_row(qw(d a b c d))]}", "0 0 0 1"); 48 | 49 | is $m->stringify, <<'EOF'; 50 | to: a b c d 51 | a 0 1 0 0 52 | b 0 0 1 1 53 | c 0 0 0 0 54 | d 0 0 0 1 55 | EOF 56 | 57 | is scalar Graph::BitMatrix->new($g, transpose => 1)->stringify, <<'EOF'; 58 | to: a b c d 59 | a 0 0 0 0 60 | b 1 0 0 0 61 | c 0 1 0 0 62 | d 0 1 0 1 63 | EOF 64 | 65 | is( $m->get(qw(x x)), undef ); 66 | 67 | is("@{[sort $m->vertices]}", "a b c d"); 68 | 69 | $m->set_row(qw(b a c)); 70 | is("@{[$m->get_row(qw(b a b c d))]}", "1 0 1 1"); 71 | $m->unset_row(qw(b c d)); 72 | is("@{[$m->get_row(qw(b a b c d))]}", "1 0 0 0"); 73 | 74 | eval { Graph::BitMatrix->new($g, nonesuch => 1) }; 75 | like($@, qr/Graph::BitMatrix::new: Unknown option: 'nonesuch' /); 76 | -------------------------------------------------------------------------------- /t/84_all_cessors.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph::Directed; 5 | use Graph::Undirected; 6 | 7 | sub test_graphs { 8 | my ($graphs, $methods, $label) = @_; 9 | for my $m (sort keys %$methods) { 10 | my $this_m = $methods->{$m}; 11 | for my $k (sort keys %$this_m) { 12 | my $g = $graphs->{$k}; 13 | my $gs = $g->stringify; 14 | for my $call ( @{ $this_m->{$k} } ) { 15 | my ($arg, $expected) = @$call; 16 | my @args = split ' ', $arg; 17 | is "@{[sort $g->$m(@args)]}", $expected, "$label $k($gs) $m (@args)"; 18 | } 19 | } 20 | } 21 | } 22 | 23 | sub make_graphs { 24 | my ($spec, $class, $l) = @_; 25 | +{ map { 26 | my ($V, $E) = @{ $spec->{$_} }; 27 | my $g = $class->new; 28 | $g->add_vertices(@$V); 29 | $g->add_edge(@$_) for @$E; 30 | ($l.$_ => $g); 31 | } keys %$spec }; 32 | } 33 | 34 | my %V_E = ( 35 | 0 => [ [], [] ], 36 | 1 => [ [qw(a)], [] ], 37 | '2a' => [ [qw(a b)], [] ], 38 | '2b' => [ [], [[qw(a b)]] ], 39 | '2c' => [ [], [[qw(a b)], [qw(b a)]] ], 40 | 3 => [ [], [[qw(a b)], [qw(a c)], [qw(b d)], [qw(b e)], [qw(c f)], [qw(c g)]] ], 41 | 4 => [ [], [[qw(a b)], [qw(b a)], [qw(a a)]] ], 42 | 5 => [ [], [[qw(a a)]] ], 43 | ); 44 | 45 | { 46 | my $dg = make_graphs(\%V_E, 'Graph::Directed', 'd'); 47 | is $dg->{$_->[0]}, $_->[1], $_->[0] for ( 48 | [ d0 => "" ], 49 | [ d1 => "a" ], 50 | [ d2a => "a,b" ], 51 | [ d2b => "a-b" ], 52 | [ d2c => "a-b,b-a" ], 53 | [ d3 => "a-b,a-c,b-d,b-e,c-f,c-g" ], 54 | [ d4 => "a-a,a-b,b-a" ], 55 | [ d5 => "a-a" ], 56 | ); 57 | test_graphs($dg, { 58 | all_successors => { 59 | d0 => [ ['a', ""] ], 60 | d1 => [ ['a', ""] ], 61 | d2a => [ ['a', ""], ['b', ""] ], 62 | d2b => [ ['a', "b"], ['b', ""] ], 63 | d2c => [ ['a', "a b"], ['b', "a b"] ], 64 | d3 => [ ['a', "b c d e f g"], ['b', "d e"], ['c', "f g"], ['d', ""], ['e', ""], ['f', ""], ['g', ""] ], 65 | d4 => [ ['a', "a b"], ['b', "a b"] ], 66 | d5 => [ ['a', "a"] ], 67 | }, 68 | all_predecessors => { 69 | d0 => [ ['a', ""] ], 70 | d1 => [ ['a', ""] ], 71 | d2a => [ ['a', ""], ['b', ""] ], 72 | d2b => [ ['a', ""], ['b', "a"] ], 73 | d2c => [ ['a', "a b"], ['b', "a b"] ], 74 | d3 => [ ['a', ""], ['b', "a"], ['c', "a"], ['d', "a b"], ['e', "a b"], ['f', "a c"], ['g', "a c"] ], 75 | d4 => [ ['a', "a b"], ['b', "a b"] ], 76 | d5 => [ ['a', "a"] ], 77 | }, 78 | predecessors_by_radius => { 79 | d0 => [ ['a 1', ""] ], 80 | d1 => [ ['a 1', ""] ], 81 | d2a => [ ['a 1', ""], ['b 1', ""] ], 82 | d2b => [ ['a 1', ""], ['b 1', "a"], ['b 2', "a"] ], 83 | d2c => [ ['a 0', ""], ['b 1', "a"], ['b 2', "a b"] ], 84 | d3 => [ ['a 1', ""], ['b 1', "a"], ['c 2', "a"], ['d 1', "b"], ['d 2', "a b"], ['e 1', "b"], ['f 1', "c"], ['g 1', "c"], ['g 2', "a c"] ], 85 | d4 => [ ['a 1', "a b"], ['b 1', "a"] ], 86 | d5 => [ ['a 1', "a"] ], 87 | }, 88 | all_neighbors => { 89 | d0 => [ ['a', ""] ], 90 | d1 => [ ['a', ""] ], 91 | d2a => [ ['a', ""], ['b', ""] ], 92 | d2b => [ ['a', "b"], ['b', "a"] ], 93 | d2c => [ ['a', "b"], ['b', "a"] ], 94 | d3 => [ ['a', "b c d e f g"], ['b', "a c d e f g"], ['c', "a b d e f g"], ['d', "a b c e f g"], ['e', "a b c d f g"], ['f', "a b c d e g"], ['g', "a b c d e f"] ], 95 | d4 => [ ['a', "a b"], ['b', "a"] ], 96 | d5 => [ ['a', "a"] ], 97 | }, 98 | all_reachable => { 99 | d0 => [ ['a', ""] ], 100 | d1 => [ ['a', ""] ], 101 | d2a => [ ['a', ""], ['b', ""] ], 102 | d2b => [ ['a', "b"], ['b', ""] ], 103 | d2c => [ ['a', "a b"], ['b', "a b"] ], 104 | d3 => [ ['a', "b c d e f g"], ['b', "d e"], ['c', "f g"], ['d', ""], ['e', ""], ['f', ""], ['g', ""] ], 105 | d4 => [ ['a', "a b"], ['b', "a b"] ], 106 | d5 => [ ['a', "a"] ], 107 | }, 108 | }, 'directed'); 109 | } 110 | 111 | { 112 | my $dg = make_graphs(\%V_E, 'Graph::Undirected', 'u'); 113 | is $dg->{$_->[0]}, $_->[1], $_->[0] for ( 114 | [ u0 => "" ], 115 | [ u1 => "a" ], 116 | [ u2a => "a,b" ], 117 | [ u2b => "a=b" ], 118 | [ u2c => "a=b" ], 119 | [ u3 => "a=b,a=c,b=d,b=e,c=f,c=g" ], 120 | [ u4 => "a=a,a=b" ], 121 | [ u5 => "a=a" ], 122 | ); 123 | test_graphs($dg, { 124 | all_neighbors => { 125 | u0 => [ ['a', ""] ], 126 | u1 => [ ['a', ""] ], 127 | u2a => [ ['a', ""], ['b', ""] ], 128 | u2b => [ ['a', "b"], ['b', "a"] ], 129 | u2c => [ ['a', "b"], ['b', "a"] ], 130 | u3 => [ ['a', "b c d e f g"], ['b', "a c d e f g"], ['c', "a b d e f g"], ['d', "a b c e f g"], ['e', "a b c d f g"], ['f', "a b c d e g"], ['g', "a b c d e f"] ], 131 | u4 => [ ['a', "a b"], ['b', "a"] ], 132 | u5 => [ ['a', "a"] ], 133 | }, 134 | all_reachable => { 135 | u0 => [ ['a', ""] ], 136 | u1 => [ ['a', ""] ], 137 | u2a => [ ['a', ""], ['b', ""] ], 138 | u2b => [ ['a', "b"], ['b', "a"] ], 139 | u2c => [ ['a', "b"], ['b', "a"] ], 140 | u3 => [ ['a', "b c d e f g"], ['b', "a c d e f g"], ['c', "a b d e f g"], ['d', "a b c e f g"], ['e', "a b c d f g"], ['f', "a b c d e g"], ['g', "a b c d e f"] ], 141 | u4 => [ ['a', "a b"], ['b', "a"] ], 142 | u5 => [ ['a', "a"] ], 143 | }, 144 | }, 'undirected'); 145 | } 146 | 147 | { 148 | my $d0 = Graph::Directed->new; 149 | $d0->add_edge(0,1); 150 | $d0->add_edge(1,0); 151 | my @g = sort $d0->all_successors(0); 152 | is_deeply \@g, [ 0, 1 ], 153 | 'all_successors works on false names' or diag explain \@g; 154 | } 155 | 156 | done_testing; 157 | -------------------------------------------------------------------------------- /t/85_subgraph.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Graph; 5 | use Graph::Directed; 6 | use Graph::Undirected; 7 | 8 | use Test::More; 9 | 10 | my $g0 = Graph::Directed->new; 11 | my @E = ([qw(a b)], [qw(a c)], [qw(b d)], [qw(b e)], [qw(c f)], [qw(c g)]); 12 | $g0->add_edges(@E); 13 | 14 | is $g0->subgraph([qw(a b c)], [qw(d e f)]), "b-d,b-e,c-f,a"; 15 | is $g0->subgraph([qw(a b c)]), "a-b,a-c"; 16 | is $g0->subgraph(['a'],['e']), "a,e"; 17 | 18 | is($g0->subgraph_by_radius('a', 0)->stringify, "a"); 19 | is($g0->subgraph_by_radius('a', 1)->stringify, "a-b,a-c"); 20 | is($g0->subgraph_by_radius('a', 2)->stringify, "a-b,a-c,b-d,b-e,c-f,c-g"); 21 | is($g0->subgraph_by_radius('a', 3)->stringify, "a-b,a-c,b-d,b-e,c-f,c-g"); 22 | 23 | is($g0->subgraph_by_radius('b', 0)->stringify, "b"); 24 | is($g0->subgraph_by_radius('b', 1)->stringify, "b-d,b-e"); 25 | is($g0->subgraph_by_radius('b', 2)->stringify, "b-d,b-e"); 26 | is($g0->subgraph_by_radius('b', 3)->stringify, "b-d,b-e"); 27 | 28 | is($g0->subgraph_by_radius('a', 'b', 1)->stringify, "a-b,a-c,b-d,b-e"); 29 | 30 | my $g1 = Graph::Undirected->new; 31 | $g1->add_edges(@E); 32 | 33 | is $g1->subgraph([qw(a b c)], [qw(d e f)]), "b=d,b=e,c=f,a"; 34 | is $g1->subgraph([qw(a b c)]), "a=b,a=c"; 35 | is $g1->subgraph(['a'],['e']), "a,e"; 36 | 37 | is($g1->subgraph_by_radius('a', 0)->stringify, "a"); 38 | is($g1->subgraph_by_radius('a', 1)->stringify, "a=b,a=c"); 39 | is($g1->subgraph_by_radius('a', 2)->stringify, "a=b,a=c,b=d,b=e,c=f,c=g"); 40 | is($g1->subgraph_by_radius('a', 3)->stringify, "a=b,a=c,b=d,b=e,c=f,c=g"); 41 | 42 | is($g1->subgraph_by_radius('b', 0)->stringify, "b"); 43 | is($g1->subgraph_by_radius('b', 1)->stringify, "a=b,b=d,b=e"); 44 | is($g1->subgraph_by_radius('b', 2)->stringify, "a=b,a=c,b=d,b=e"); 45 | is($g1->subgraph_by_radius('b', 3)->stringify, "a=b,a=c,b=d,b=e,c=f,c=g"); 46 | 47 | done_testing(); 48 | -------------------------------------------------------------------------------- /t/86_bipartite.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | 4 | use Graph::Undirected; 5 | 6 | my $g0 = Graph::Undirected->new; 7 | $g0->add_path('A'..'Z'); 8 | ok($g0->is_bipartite); 9 | 10 | my $g1 = Graph::Undirected->new; 11 | $g1->add_cycle('A'..'C'); 12 | ok(!$g1->is_bipartite); 13 | 14 | my $g2 = Graph::Undirected->new; 15 | $g2->add_cycle('A'..'D'); 16 | ok($g2->is_bipartite); 17 | 18 | my $g3 = Graph::Undirected->new; 19 | for my $A ('A'..'Z') { 20 | for my $B ('1'..'9') { 21 | $g3->add_edge($A, $B); 22 | } 23 | } 24 | ok($g3->is_bipartite); 25 | 26 | my $g4 = Graph::Undirected->new; 27 | $g4->add_cycle('A'..'C'); 28 | $g4->add_cycle('1'..'6'); 29 | ok(!$g4->is_bipartite); 30 | 31 | my $g5 = Graph::Undirected->new; 32 | $g5->add_cycle('A'..'D'); 33 | $g5->add_cycle('1'..'6'); 34 | ok($g5->is_bipartite); 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/87_planar.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Graph::Undirected; 5 | 6 | use Test::More; 7 | 8 | my $g0 = Graph::Undirected->new; 9 | $g0->add_path('A'..'Z'); 10 | ok($g0->is_planar); 11 | 12 | my $g1 = Graph::Undirected->new; 13 | $g1->add_cycle('A'..'C'); 14 | ok($g1->is_planar); 15 | 16 | my $g2 = Graph::Undirected->new; 17 | $g2->add_cycle('A'..'D'); 18 | ok($g2->is_planar); 19 | 20 | my $g3 = Graph::Undirected->new; 21 | for my $A ('A'..'Z') { 22 | for my $B ('1'..'9') { 23 | $g3->add_edge($A, $B); 24 | } 25 | } 26 | ok(!$g3->is_planar); 27 | 28 | my $g4 = Graph::Undirected->new; 29 | $g4->add_cycle('A'..'C'); 30 | $g4->add_cycle('1'..'6'); 31 | ok($g4->is_planar); 32 | 33 | my $g5 = Graph::Undirected->new; 34 | $g5->add_cycle('A'..'D'); 35 | $g5->add_cycle('1'..'6'); 36 | ok($g5->is_planar); 37 | 38 | my $g6 = Graph::Undirected->new; # K5 39 | for my $A ('A'..'E') { 40 | for my $B ('A'..'E') { 41 | next if $A eq $B; 42 | $g6->add_edge( $A, $B ); 43 | } 44 | } 45 | ok(!$g6->is_planar); 46 | 47 | my $g7 = Graph::Undirected->new; # K3,3 48 | for my $A ('A'..'C') { 49 | for my $B ('1'..'3') { 50 | $g7->add_edge( $A, $B ); 51 | } 52 | } 53 | ok(!$g7->is_planar); 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /t/88_max_cliq.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Graph::Undirected; 5 | 6 | use Test::More; 7 | 8 | my $g0 = Graph::Undirected->new; 9 | $g0->add_vertices('A', 'B'); 10 | 11 | is_deeply [map [sort @$_], @{ $g0->max_cliques }], [['A'], ['B']], 'no edges'; 12 | 13 | my $g1 = Graph::Undirected->new; 14 | $g1->add_edges(map split(/-/), qw( a-b b-c a-c x-y y-z u-v )); 15 | $g1->add_vertex('w'); 16 | my $mc = $g1->max_cliques; # Scalar context. 17 | is_deeply [sort { $a->[0] cmp $b->[0] } map [sort @$_], @$mc], 18 | [['a', 'b', 'c'], ['u', 'v'], ['w'], ['x', 'y'], ['y', 'z']], 19 | 'cliques of sizes 1..3'; 20 | 21 | my $g2 = Graph::Undirected->new; 22 | $g2->add_edges(map split(/-/), qw( kh-tc qp-kh de-cg ka-co yn-aq qp-ub 23 | cg-tb vc-aq tb-ka wh-tc yn-cg kh-ub 24 | ta-co de-co tc-td tb-wq wh-td ta-ka 25 | td-qp aq-cg wq-ub ub-vc de-ta wq-aq 26 | wq-vc wh-yn ka-de kh-ta co-tc wh-qp 27 | tb-vc td-yn )); 28 | my @mc = $g2->max_cliques; # List context. 29 | is_deeply [sort { "@$a" cmp "@$b" } map [sort @$_], @mc], 30 | [ 31 | [qw[ aq cg yn ]], 32 | [qw[ aq vc wq ]], 33 | [qw[ cg de ]], 34 | [qw[ cg tb ]], 35 | [qw[ co de ka ta ]], 36 | [qw[ co tc ]], 37 | [qw[ ka tb ]], 38 | [qw[ kh qp ub ]], 39 | [qw[ kh ta ]], 40 | [qw[ kh tc ]], 41 | [qw[ qp td wh ]], 42 | [qw[ tb vc wq ]], 43 | [qw[ tc td wh ]], 44 | [qw[ td wh yn ]], 45 | [qw[ ub vc wq ]] 46 | ], 47 | 'Advent of Code 2024 Day 23 Part 2'; 48 | 49 | done_testing; 50 | -------------------------------------------------------------------------------- /t/89_connected_subgraphs.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Graph::Undirected; 5 | 6 | use Test::More; 7 | 8 | my $g; 9 | my @subgraphs; 10 | 11 | # Caffeine molecule, heavy atoms only 12 | $g = Graph::Undirected->new; 13 | $g->add_path('A'..'K'); 14 | $g->add_edge('C', 'L'); 15 | $g->add_edge('E', 'M'); 16 | $g->add_edge('I', 'N'); 17 | $g->add_edge('B', 'J'); 18 | $g->add_edge('D', 'H'); 19 | 20 | @subgraphs = $g->connected_subgraphs; 21 | is(@subgraphs, 1153); 22 | 23 | my @by_size; 24 | for (@subgraphs) { 25 | $by_size[scalar $_->vertices]++; 26 | } 27 | 28 | my @result0 = qw( 0 14 15 23 40 68 112 165 206 208 162 93 37 9 1 ); 29 | 30 | for (1..$#result0) { 31 | is($by_size[$_], $result0[$_]); 32 | } 33 | 34 | # K5 35 | $g = Graph::Undirected->new; 36 | for my $i (1..5) { 37 | for my $j ($i+1..5) { 38 | $g->add_edge($i, $j); 39 | } 40 | } 41 | 42 | @subgraphs = $g->connected_subgraphs; 43 | is(@subgraphs, 31); 44 | 45 | # Line of 5 vertices 46 | $g = Graph::Undirected->new; 47 | $g->add_path(1..5); 48 | 49 | @subgraphs = $g->connected_subgraphs; 50 | is(@subgraphs, 15); 51 | 52 | done_testing; 53 | -------------------------------------------------------------------------------- /t/99_misc.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | 3 | use Test::More; 4 | 5 | use Graph::Directed; 6 | use Graph::Undirected; 7 | 8 | my @E = ([qw(a b)], [qw(a c)], [qw(b d)], [qw(b e)], [qw(c f)], [qw(c g)]); 9 | 10 | { 11 | my $gi0 = Graph->new; 12 | $gi0->set_edge_attribute(qw(a b), weight => 1); 13 | my $gi1 = Graph->new; 14 | $gi1->set_vertex_attribute('x', shape => 1); 15 | $gi1->set_edge_attribute(qw(x y), weight => 2); 16 | is_deeply [ $gi0->ingest($gi1)->as_hashes ], [ 17 | { x => { shape => 1 }, map +($_ => {}), qw(a b y) }, 18 | { a => { b => { weight => 1 } }, x => { y => { weight => 2 } } }, 19 | ]; 20 | } 21 | 22 | for ({}, {countvertexed => 1}, {multivertexed => 1}) { 23 | my $gr = Graph::Directed->new(%$_); 24 | $gr->add_edge(@$_) for @E; 25 | $gr->rename_vertex('b', 'b1'); 26 | my $label = ref($gr->[ 2 ]) . ' {' . join('=>', %$_) . '}'; 27 | is $gr, "a-b1,a-c,b1-d,b1-e,c-f,c-g", $label; 28 | $gr->rename_vertices(sub { uc $_[0] }); 29 | is $gr, "A-B1,A-C,B1-D,B1-E,C-F,C-G", $label; 30 | } 31 | 32 | for ({}, {multivertexed => 1}, {multiedged => 1}) { 33 | my $g = Graph::Directed->new(%$_); 34 | $g->add_edge(@$_) for @E; 35 | my $label = ref($g->[ 2 ]) . ' {' . join('=>', %$_) . '}'; 36 | is $g, "a-b,a-c,b-d,b-e,c-f,c-g", $label; 37 | $g->filter_edges(sub {$_[2] ne 'g'}); 38 | is $g, "a-b,a-c,b-d,b-e,c-f,g", $label; 39 | $g->filter_vertices(sub {$_[1] !~ /[fg]/}); 40 | is $g, "a-b,a-c,b-d,b-e", $label; 41 | } 42 | 43 | my $g2 = Graph->new; 44 | is_deeply [ $g2->clustering_coefficient ], [], 45 | 'clustering_coefficient with no vertices = empty list'; 46 | 47 | for my $p (qw(zero 48 | one 49 | two 50 | three 51 | four 52 | five 53 | six 54 | seven 55 | eight 56 | nine 57 | ten)) { 58 | $g2->add_path(split(//, $p)); 59 | } 60 | 61 | my ($gamma, %clustering) = $g2->clustering_coefficient; 62 | 63 | my $eps = 1e-6; 64 | 65 | ok(abs($gamma - 0.402222222222222) <= $eps); 66 | ok(abs($clustering{e} - 0.7) <= $eps); 67 | ok(abs($clustering{t} - 1/3) <= $eps); 68 | is($clustering{z}, 0.0); 69 | is($clustering{r}, 1.0); 70 | 71 | my %betweenness = $g2->betweenness; 72 | 73 | ok(abs($betweenness{e} - 60.3333333333333) <= $eps); 74 | ok(abs($betweenness{t} - 17.1666666666667) <= $eps); 75 | is($betweenness{x}, 0.0); 76 | is($betweenness{u}, 3.0); 77 | 78 | { 79 | my $w = ''; 80 | local $SIG{__WARN__} = sub { $w = shift }; 81 | my $g3 = Graph->new; 82 | $g3->add_edge(0,1); 83 | my @dummy = $g3->SP_Dijkstra(1,0); 84 | is $w, ''; 85 | } 86 | 87 | is_deeply [ sort(Graph::__fisher_yates_shuffle(1..3)) ], [ 1..3 ]; 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/MyDGraph.pm: -------------------------------------------------------------------------------- 1 | package DGraph; 2 | use strict; use warnings; 3 | require Graph::Directed; 4 | @DGraph::ISA=qw(Graph::Directed); 5 | 1; 6 | -------------------------------------------------------------------------------- /t/MyGraph.pm: -------------------------------------------------------------------------------- 1 | package MyGraph; 2 | 3 | use strict; use warnings; 4 | use Graph; 5 | use base 'Graph'; 6 | 7 | 1; 8 | -------------------------------------------------------------------------------- /t/MyUGraph.pm: -------------------------------------------------------------------------------- 1 | package UGraph; 2 | use strict; use warnings; 3 | require Graph::Undirected; 4 | @UGraph::ISA=qw(Graph::Undirected); 5 | 1; 6 | -------------------------------------------------------------------------------- /t/simple.pl: -------------------------------------------------------------------------------- 1 | # Simple classes for testing. 2 | 3 | use strict; use warnings; 4 | sub Foo::new { 5 | bless { foo => $_[1] }, $_[0]; 6 | } 7 | 8 | sub Foo::xyz { 9 | 1; 10 | } 11 | 12 | sub Bar::new { 13 | bless { bar => $_[1] }, $_[0]; 14 | } 15 | 16 | sub Bar::xyz { 17 | 1; 18 | } 19 | 20 | { 21 | package Bar; 22 | use Scalar::Util qw(refaddr); 23 | use overload '""' => \&str, eq => \&eq, ne => \≠ 24 | sub str { refaddr $_[0] } 25 | sub eq { 26 | my $d0 = defined $_[0]->{bar}; 27 | my $d1 = defined $_[1]->{bar}; 28 | $d0 && $d1 ? $_[0]->{bar} eq $_[1]->{bar} : 29 | $d0 || $d0 ? 0 : 1; 30 | } 31 | sub ne { 32 | my $d0 = defined $_[0]->{bar}; 33 | my $d1 = defined $_[1]->{bar}; 34 | $d0 && $d1 ? $_[0]->{bar} ne $_[1]->{bar} : 35 | $d0 || $d0 ? 1 : 0; 36 | } 37 | } 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /t/u_at2.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 4; 2 | 3 | use strict; use warnings; 4 | use Graph::Undirected; 5 | 6 | my $g = Graph::Undirected->new; 7 | 8 | while () { 9 | if (/(\S+)\s+(\S+)/) { 10 | $g->add_edge($1, $2); 11 | } 12 | } 13 | 14 | my $src = "NRTPZ5WOkg"; 15 | my $dst = "ObpULOKHH0"; 16 | 17 | my @u = qw(NRTPZ5WOkg 18 | vJqD6skXdS 19 | TNgfs0KcUd 20 | qI7Po3TrBA 21 | ZiPHVw509v 22 | bnDd3VuBpJ 23 | ObpULOKHH0); 24 | 25 | for (1, 2) { 26 | print "# finding SP_Dijkstra path between $src and $dst\n"; 27 | my @v = $g->SP_Dijkstra($src, $dst); 28 | is_deeply(\@v, \@u); 29 | foreach (@v) { 30 | print "# $_\n"; 31 | } 32 | { 33 | print "# finding APSP_Floyd_Warshall path between $src and $dst\n"; 34 | my $apsp = $g->APSP_Floyd_Warshall(); 35 | my @v = $apsp->path_vertices($src, $dst); 36 | is_deeply(\@v, \@u); 37 | foreach (@v) { 38 | print "# $_\n"; 39 | } 40 | } 41 | } 42 | 43 | __END__ 44 | Cwx0nn09zg pDRu7q707v 45 | ENQH4XaK3o bnuPl9BV2A 46 | J6UG5junOo UNQcGQ7Yxs 47 | J6UG5junOo vZJeF6iWP5 48 | JU5fopQvgK Cqw1sHOUJ1 49 | JU5fopQvgK Cwx0nn09zg 50 | NRTPZ5WOkg Cqw1sHOUJ1 51 | NRTPZ5WOkg vJqD6skXdS 52 | ObpULOKHH0 bnDd3VuBpJ 53 | Ody8vNNKOn bnDd3VuBpJ 54 | Ody8vNNKOn nONYKw3o4X 55 | RlBKE0bWDY p5gUeVx6pZ 56 | UNQcGQ7Yxs els2v8URGW 57 | ZiPHVw509v qI7Po3TrBA 58 | bnDd3VuBpJ ZiPHVw509v 59 | bnuPl9BV2A eiTqtOz3aL 60 | eiTqtOz3aL pDRu7q707v 61 | els2v8URGW IDU5MGPovY 62 | p5gUeVx6pZ IDU5MGPovY 63 | pWZsc88Hfm RlBKE0bWDY 64 | pWZsc88Hfm nONYKw3o4X 65 | qI7Po3TrBA TNgfs0KcUd 66 | vJqD6skXdS TNgfs0KcUd 67 | vZJeF6iWP5 ENQH4XaK3o 68 | -------------------------------------------------------------------------------- /t/u_at3.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 44; 2 | 3 | use strict; use warnings; 4 | use Graph::Undirected; 5 | 6 | my $g = Graph::Undirected->new; 7 | 8 | $g->add_edge("a", "b"); 9 | $g->add_edge("c", "d"); 10 | 11 | for (1..10) { 12 | my @v1 = $g->SP_Dijkstra("a", "c"); 13 | is(@v1, 0); 14 | my @v2 = $g->SP_Dijkstra("a", "d"); 15 | is(@v2, 0); 16 | my @v3 = $g->SP_Dijkstra("b", "c"); 17 | is(@v3, 0); 18 | my @v4 = $g->SP_Dijkstra("b", "d"); 19 | is(@v4, 0); 20 | } 21 | 22 | $g->add_edge("c", "b"); 23 | 24 | my @v1 = $g->SP_Dijkstra("a", "c"); 25 | is("@v1", "a b c"); 26 | my @v2 = $g->SP_Dijkstra("a", "d"); 27 | is("@v2", "a b c d"); 28 | my @v3 = $g->SP_Dijkstra("b", "c"); 29 | is("@v3", "b c"); 30 | my @v4 = $g->SP_Dijkstra("b", "d"); 31 | is("@v4", "b c d"); 32 | -------------------------------------------------------------------------------- /t/u_bb_rv.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 11; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Graph; 7 | 8 | my ($u, $v); 9 | 10 | my $g1 = Graph->new(refvertexed => 1); 11 | use Math::Complex qw(cplx); 12 | $g1->add_edge($u = cplx(1,2), $v = cplx(3,4)); 13 | is($g1, "$u-$v"); 14 | $g1->delete_vertex($u); 15 | is($g1, $v); 16 | $g1->delete_vertex($v); 17 | is($g1, ""); 18 | 19 | my $g2 = Graph->new(refvertexed => 1); 20 | use Math::Complex qw(cplx); 21 | $g2->add_vertex($u = cplx(1,2)); 22 | is($g2, $u); 23 | $g2->add_vertex($v = cplx(3,4)); 24 | is($g2, "$u,$v"); 25 | $g2->delete_vertex($u); 26 | is($g2, $v); 27 | $g2->delete_vertex($v); 28 | is($g2, ""); 29 | 30 | my $g3 = Graph->new(refvertexed => 1); 31 | use Math::Complex qw(cplx); 32 | $g3->add_edge($u = cplx(1,2), $v = cplx(3,4)); 33 | is($g3, "$u-$v"); 34 | $g3->delete_edge($u, $v); 35 | is($g3, "$u,$v"); 36 | $g3->delete_vertex($u); 37 | is($g3, $v); 38 | $g3->delete_vertex($v); 39 | is($g3, ""); 40 | 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /t/u_bf.t: -------------------------------------------------------------------------------- 1 | # rt.cpan.org #20185: problem with SPT_Bellman_Ford 2 | 3 | use strict; 4 | 5 | use Test::More tests => 7; 6 | 7 | use Graph; 8 | use Graph::Directed; 9 | use Graph::Undirected; 10 | 11 | my $g_1 = Graph::Undirected -> new(unionfind => 1); 12 | 13 | my @edge = 14 | ( 15 | [ '16977', '14903' ], 16 | [ '21062', '4504' ], 17 | [ '14671', '10554' ], 18 | [ '14903', '8891' ], 19 | [ '9714', '14671' ], 20 | [ '4504', '13544' ], 21 | [ '9714', '13544' ], 22 | [ '16977', '8891' ], 23 | [ '21062', '21062' ], 24 | [ '9714', '4504' ], 25 | [ '14671', '21687' ], 26 | [ '14671', '16977' ], 27 | [ '4504', '21687' ], 28 | [ '10554', '14903' ], 29 | [ '9714', '21687' ], 30 | [ '13544', '14671' ], 31 | [ '21062', '14671' ], 32 | [ '10554', '8891' ], 33 | [ '14671', '14903' ], 34 | [ '14671', '14671' ], 35 | [ '13544', '13544' ], 36 | [ '14671', '14026' ], 37 | [ '4504', '14671' ], 38 | [ '14671', '8891' ], 39 | [ '13544', '14026' ], 40 | [ '10554', '16977' ], 41 | ); 42 | 43 | $g_1 -> add_edges(@edge); 44 | 45 | my $spt_1 = $g_1 -> SPT_Bellman_Ford; 46 | 47 | is($spt_1->vertices, $g_1->vertices); 48 | 49 | my $g_2 = Graph::Undirected -> new(); 50 | 51 | $g_2 -> add_edges(@edge); 52 | 53 | my $spt_2 = $g_2 -> SPT_Bellman_Ford; 54 | 55 | is($spt_2->vertices, $g_2->vertices); 56 | 57 | my $g_3 = Graph::Directed -> new(); 58 | 59 | $g_3 -> add_edges(@edge); 60 | 61 | my $spt_3a = $g_3 -> SPT_Bellman_Ford('21062'); 62 | 63 | is($spt_3a->vertices, $g_3->vertices - 1); 64 | ok(!$spt_3a->has_vertex('9714')); 65 | 66 | my $spt_3b = $g_3 -> SPT_Bellman_Ford('4504'); 67 | 68 | is($spt_3b->vertices, $g_3->vertices - 2); 69 | ok(!$spt_3b->has_vertex('9714')); 70 | ok(!$spt_3b->has_vertex('21062')); 71 | -------------------------------------------------------------------------------- /t/u_bill.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 30; 2 | 3 | use strict; 4 | use Graph::Undirected; 5 | 6 | my$g = new Graph::Undirected; 7 | $g->add_edges(qw(a1 b1 b1 c1 c1 a1 a2 b2 b2 c2 c2 a2 a1 a2)); 8 | $g->add_vertices(1..5); 9 | 10 | foreach (1..10) { 11 | my @b = $g->bridges; 12 | is(@b, 1); 13 | my ($u, $v) = sort @{ $b[0] }; 14 | is($u, "a1"); 15 | is($v, "a2"); 16 | } 17 | -------------------------------------------------------------------------------- /t/u_bo_ap1.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | use Graph::Undirected; 4 | 5 | use strict; 6 | 7 | my $g = Graph::Undirected->new; 8 | 9 | while () { 10 | chomp; 11 | my ($v1,$v2) = split ','; 12 | $g->add_edge($v1, $v2); 13 | } 14 | 15 | my $R = 3; 16 | 17 | plan tests => $R * scalar $g->vertices; 18 | 19 | my @exp = "DIP:3047N DIP:3051N DIP:3053N DIP:3056N DIP:3059N DIP:3069N DIP:3075N DIP:3089N DIP:3095N DIP:3101N DIP:3103N DIP:3109N DIP:3120N"; 20 | 21 | for my $v ($g->vertices) { 22 | for (1..$R) { 23 | my @rts = sort $g->articulation_points(first_root => $v); 24 | is("@rts", "@exp"); 25 | $g->biconnectivity_clear_cache; 26 | } 27 | } 28 | 29 | __END__ 30 | DIP:3048N,DIP:3047N 31 | DIP:3050N,DIP:3047N 32 | DIP:3051N,DIP:3051N 33 | DIP:3052N,DIP:3051N 34 | DIP:3053N,DIP:3051N 35 | DIP:3054N,DIP:3051N 36 | DIP:3055N,DIP:3056N 37 | DIP:3057N,DIP:3056N 38 | DIP:3058N,DIP:3056N 39 | DIP:3059N,DIP:3056N 40 | DIP:3060N,DIP:3056N 41 | DIP:3061N,DIP:3056N 42 | DIP:3062N,DIP:3056N 43 | DIP:3063N,DIP:3056N 44 | DIP:3064N,DIP:3056N 45 | DIP:3065N,DIP:3056N 46 | DIP:3066N,DIP:3056N 47 | DIP:3067N,DIP:3056N 48 | DIP:3053N,DIP:3056N 49 | DIP:3068N,DIP:3056N 50 | DIP:3070N,DIP:3069N 51 | DIP:3071N,DIP:3069N 52 | DIP:3072N,DIP:3069N 53 | DIP:3073N,DIP:3069N 54 | DIP:3074N,DIP:3074N 55 | DIP:3053N,DIP:3074N 56 | DIP:3075N,DIP:3075N 57 | DIP:3076N,DIP:3075N 58 | DIP:3077N,DIP:3075N 59 | DIP:3078N,DIP:3075N 60 | DIP:3079N,DIP:3075N 61 | DIP:3080N,DIP:3075N 62 | DIP:3081N,DIP:3075N 63 | DIP:3082N,DIP:3075N 64 | DIP:3083N,DIP:3075N 65 | DIP:3084N,DIP:3075N 66 | DIP:3085N,DIP:3075N 67 | DIP:3086N,DIP:3075N 68 | DIP:3087N,DIP:3075N 69 | DIP:3088N,DIP:3075N 70 | DIP:3090N,DIP:3089N 71 | DIP:3091N,DIP:3089N 72 | DIP:3092N,DIP:3089N 73 | DIP:3093N,DIP:3089N 74 | DIP:3094N,DIP:3089N 75 | DIP:3082N,DIP:3089N 76 | DIP:3083N,DIP:3089N 77 | DIP:3095N,DIP:3089N 78 | DIP:3096N,DIP:3089N 79 | DIP:3097N,DIP:3089N 80 | DIP:3087N,DIP:3089N 81 | DIP:3098N,DIP:3089N 82 | DIP:3099N,DIP:3089N 83 | DIP:3100N,DIP:3089N 84 | DIP:3102N,DIP:3101N 85 | DIP:3103N,DIP:3101N 86 | DIP:3104N,DIP:3101N 87 | DIP:3095N,DIP:3101N 88 | DIP:3105N,DIP:3101N 89 | DIP:3106N,DIP:3101N 90 | DIP:3107N,DIP:3107N 91 | DIP:3108N,DIP:3108N 92 | DIP:3110N,DIP:3109N 93 | DIP:3111N,DIP:3109N 94 | DIP:3112N,DIP:3109N 95 | DIP:3112N,DIP:3111N 96 | DIP:3059N,DIP:3109N 97 | DIP:3113N,DIP:3109N 98 | DIP:3114N,DIP:3109N 99 | DIP:3115N,DIP:3109N 100 | DIP:3116N,DIP:3109N 101 | DIP:3117N,DIP:3109N 102 | DIP:3118N,DIP:3109N 103 | DIP:3119N,DIP:3119N 104 | DIP:3053N,DIP:3119N 105 | DIP:3120N,DIP:3120N 106 | DIP:3121N,DIP:3120N 107 | DIP:3122N,DIP:3120N 108 | DIP:3103N,DIP:3123N 109 | DIP:3103N,DIP:3123N 110 | DIP:3103N,DIP:3123N 111 | DIP:3122N,DIP:3120N 112 | DIP:3122N,DIP:3120N 113 | -------------------------------------------------------------------------------- /t/u_bo_apx.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 5; 2 | 3 | use Graph::Undirected; 4 | 5 | use strict; 6 | 7 | my $g = Graph::Undirected->new; 8 | 9 | $g->add_edge(qw(a b)); 10 | $g->add_edge(qw(a c)); 11 | $g->add_edge(qw(b c)); 12 | $g->add_edge(qw(b d)); 13 | $g->add_edge(qw(d e)); 14 | $g->add_edge(qw(d f)); 15 | $g->add_edge(qw(e f)); 16 | 17 | my @a1 = sort $g->articulation_points(); 18 | 19 | is("@a1", "b d"); 20 | 21 | $g->add_edge(qw(b b)); 22 | 23 | my @a2 = sort $g->articulation_points(); 24 | 25 | is("@a2", "b d"); 26 | 27 | $g->add_edge(qw(d d)); 28 | 29 | my @a3 = sort $g->articulation_points(); 30 | 31 | is("@a3", "b d"); 32 | 33 | $g->add_edge(qw(a a)); 34 | 35 | my @a4 = sort $g->articulation_points(); 36 | 37 | is("@a4", "b d"); 38 | 39 | $g->add_edge(qw(f f)); 40 | 41 | my @a5 = sort $g->articulation_points(); 42 | 43 | is("@a5", "b d"); 44 | 45 | -------------------------------------------------------------------------------- /t/u_cd_rv.t: -------------------------------------------------------------------------------- 1 | use Graph; 2 | use strict; use warnings; 3 | use Test::More tests => 2; 4 | 5 | package MyNode; 6 | use overload ('""' => '_asstring', fallback=>1); 7 | sub new { 8 | my ($class, %ops) = @_; 9 | return bless { %ops }, $class; 10 | } 11 | sub _asstring { 12 | my ($self) = @_; 13 | my $str = $self->{'name'}; 14 | return $self->{'name'}; 15 | } 16 | 1; 17 | 18 | package main; 19 | use strict; use warnings; 20 | my $gnoref = new Graph; 21 | my $gwithref = new Graph(refvertexed_stringified=>1); 22 | ok $gwithref->refvertexed_stringified; 23 | my $n1 = new MyNode('name'=>'alpha'); 24 | my $n2 = new MyNode('name'=>'beta'); 25 | $gnoref->add_edge($n1, $n2); 26 | $gwithref->add_edge($n1, $n2); 27 | 28 | is_deeply([sort keys %{$gnoref->[2]->[4]}],[sort keys %{$gwithref->[2]->[4]}]); 29 | -------------------------------------------------------------------------------- /t/u_dl_uf.t: -------------------------------------------------------------------------------- 1 | # rt.cpan.org #31608: Graph::Undirected, unionfind and connected_component 2 | 3 | use strict; 4 | 5 | use Test::More tests => 2; 6 | 7 | use Graph::Undirected; 8 | sub fill_graph 9 | { 10 | my $graph = shift; 11 | $graph->add_edge('A', 'B'); 12 | $graph->add_vertex('A'); 13 | } 14 | my $graph1 = Graph::Undirected->new('unionfind' => 1); 15 | fill_graph($graph1); 16 | is($graph1->connected_components(), 1); 17 | my $graph2 = Graph::Undirected->new('unionfind' => 0); 18 | fill_graph($graph2); 19 | is($graph2->connected_components(), 1); 20 | 21 | -------------------------------------------------------------------------------- /t/u_jh_va.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 18; 2 | use strict; use warnings; 3 | use Graph; 4 | my $g = Graph->new; 5 | 6 | $g->add_path('a'..'d'); 7 | 8 | ok( $g->has_vertex('a')); 9 | ok( $g->has_vertex('b')); 10 | ok( $g->has_vertex('c')); 11 | ok( $g->has_vertex('d')); 12 | 13 | $g->delete_vertex('d'); 14 | 15 | ok( $g->has_vertex('a')); 16 | ok( $g->has_vertex('b')); 17 | ok( $g->has_vertex('c')); 18 | ok(!$g->has_vertex('d')); 19 | 20 | $g->set_vertex_attribute('b','a',1); 21 | 22 | ok( $g->delete_vertex('b')); 23 | 24 | ok( $g->has_vertex('a')); 25 | ok(!$g->has_vertex('b')); 26 | ok( $g->has_vertex('c')); 27 | ok(!$g->has_vertex('d')); 28 | 29 | ok( $g->delete_vertex('a')); 30 | 31 | ok(!$g->has_vertex('a')); 32 | ok(!$g->has_vertex('b')); 33 | ok( $g->has_vertex('c')); 34 | ok(!$g->has_vertex('d')); 35 | -------------------------------------------------------------------------------- /t/u_mn_va.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More tests => 3; 3 | use Graph::Undirected; 4 | 5 | my $G = Graph::Undirected->new; 6 | $G->add_vertex('a'); 7 | $G->set_vertex_attribute('a', 'sim', 0); 8 | $G->add_vertex('b'); 9 | $G->set_vertex_attribute('b', 'sim', 1); 10 | $G->add_edge('a', 'b'); 11 | $G->delete_vertex('a'); 12 | ok(! $G->has_vertex('a') ); 13 | my @V = $G->vertices; 14 | is(scalar @V, 1); 15 | my %V; @V{ @V } = (); 16 | ok(exists $V{b}); 17 | 18 | -------------------------------------------------------------------------------- /t/u_ng_mst.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More qw/no_plan/; 3 | 4 | =head1 NAME 5 | 6 | Test program for Graph. 7 | 8 | =head2 SYNOPSIS 9 | 10 | perl u_ng_mst.t [ A [ D [ N ] ] ] 11 | 12 | =head2 DESCRIPTION 13 | 14 | This program constructs various trees, embeds them in general graphs, 15 | and tests various minimum spanning tree methods: MST_Kruskal, 16 | MST_Prim, MST_Dijkstra. 17 | 18 | A is arity and it defaults to 4. 19 | D is depth and it defaults to 3. 20 | N is chain/star size and it defaults to 40. (The minimum is 10.) 21 | (To use a default, specify '-'.) 22 | 23 | =head1 AUTHOR 24 | 25 | Nathan Goodman 26 | 27 | =cut 28 | 29 | my ($A, $D, $N) = @ARGV; 30 | 31 | $A = 3 if ($A || 0) < 1; 32 | $D = 4 if ($D || 0) < 1; 33 | $N = 40 if ($N || 0) < 1; 34 | 35 | use strict; 36 | use Graph; 37 | use Graph::Directed; 38 | use Graph::Undirected; 39 | 40 | for my $arity (1..$A) { 41 | for my $depth (1..$D) { 42 | print "# depth=$depth, arity=$arity\n"; 43 | # $g=construct(new Graph::Directed,$depth,$arity); 44 | my $h=construct(new Graph::Undirected,$depth,$arity); 45 | my $t=regular_tree(new Graph::Undirected,$depth,$arity); 46 | my $mst1=$h->MST_Kruskal; 47 | is($mst1,$t,"Kruskal"); 48 | my $mst2=$h->MST_Prim; 49 | is($mst2,$t,"Prim"); 50 | my $mst3=$h->MST_Dijkstra; 51 | is($mst3,$t,"Dijkstra"); 52 | # ok(1,"end of tests for depth=$depth, arity=$arity"); 53 | } 54 | } 55 | # do some long chains 56 | my $arity=1; 57 | for(my $depth=10;$depth<=$N;$depth+=10) { 58 | print "# depth=$depth, arity=$arity\n"; 59 | # $g=construct(new Graph::Directed,$depth,$arity); 60 | my $h=construct(new Graph::Undirected,$depth,$arity); 61 | my $t=regular_tree(new Graph::Undirected,$depth,$arity); 62 | my $mst1=$h->MST_Kruskal; 63 | is($mst1,$t,"Kruskal"); 64 | my $mst2=$h->MST_Prim; 65 | is($mst2,$t,"Prim"); 66 | my $mst3=$h->MST_Dijkstra; 67 | is($mst3,$t,"Dijkstra"); 68 | # ok(1,"end of tests for depth=$depth, arity=$arity"); 69 | } 70 | # do some wide stars 71 | my $depth=1; 72 | for(my $arity=10;$arity<=$N;$arity+=10) { 73 | print "# depth=$depth, arity=$arity\n"; 74 | # $g=construct(new Graph::Directed,$depth,$arity); 75 | my $h=construct(new Graph::Undirected,$depth,$arity); 76 | my $t=regular_tree(new Graph::Undirected,$depth,$arity); 77 | my $mst1=$h->MST_Kruskal; 78 | is($mst1,$t,"Kruskal"); 79 | my $mst2=$h->MST_Prim; 80 | is($mst2,$t,"Prim"); 81 | my $mst3=$h->MST_Dijkstra; 82 | is($mst3,$t,"Dijkstra"); 83 | # ok(1,"end of tests for depth=$depth, arity=$arity"); 84 | } 85 | 86 | exit; 87 | 88 | sub construct { 89 | my($g, $depth, $arity, $density)=@_; 90 | $density or $density=3; 91 | 92 | # make a tree with edge weights of1 93 | $g=regular_tree($g,$depth,$arity); 94 | # add heavier edges 95 | my @nodes=$g->vertices; 96 | my $new_edges=int $density*@nodes; 97 | for (1..$new_edges) { 98 | my $i=int rand $#nodes; 99 | my $j=int rand $#nodes; 100 | next if $g->has_edge($nodes[$i],$nodes[$j]); 101 | $g->add_weighted_edge($nodes[$i],$nodes[$j],2); 102 | } 103 | print "# V = ", scalar $g->vertices, ", E = ", scalar $g->edges, "\n"; 104 | return $g; 105 | } 106 | 107 | sub regular_tree { 108 | my($tree,$depth,$arity,$root)=@_; 109 | defined $root or do { 110 | $root=0; 111 | $tree->add_vertex($root); 112 | }; 113 | if ($depth>0) { 114 | for (my $i=0; $i<$arity; $i++) { 115 | my $child="$root/$i"; 116 | $tree->add_vertex($child); 117 | $tree->add_weighted_edge($root,$child,1); 118 | regular_tree($tree,$depth-1,$arity,$child); 119 | } 120 | } 121 | $tree; 122 | } 123 | 124 | sub is_quiet { 125 | my($a,$b,$tag)=@_; 126 | return if $a eq $b; 127 | is($a,$b,$tag); 128 | } 129 | sub ok_quiet { 130 | my($bool,$tag)=@_; 131 | return if $bool; 132 | ok($bool,$tag); 133 | } 134 | 135 | sub min { 136 | if ($#_==0) {@_=@{$_[0]} if 'ARRAY' eq ref $_[0];} 137 | return undef unless @_; 138 | if ($#_==1) {my($x,$y)=@_; return ($x<=$y?$x:$y);} 139 | my $min=shift @_; 140 | map {$min=$_ if $_<$min} @_; 141 | $min; 142 | } 143 | 144 | sub max { 145 | if ($#_==0) {@_=@{$_[0]} if 'ARRAY' eq ref $_[0];} 146 | return undef unless @_; 147 | if ($#_==1) {my($x,$y)=@_; return ($x>=$y?$x:$y);} 148 | my $max=shift @_; 149 | map {$max=$_ if $_>$max} @_; 150 | $max; 151 | } 152 | -------------------------------------------------------------------------------- /t/u_rb_cc.t: -------------------------------------------------------------------------------- 1 | use Graph::Undirected; 2 | use strict; use warnings; 3 | use Test::More tests => 2; 4 | 5 | my $mg = new Graph::Undirected; 6 | $mg->add_edges(qw(C6 H6A S1 C6)); 7 | 8 | is($mg->connected_component_by_vertex("S1"), 0); 9 | my @cc0 = $mg->connected_component_by_index(0); 10 | my %cc0; @cc0{ @cc0 } = (); 11 | ok(exists $cc0{ S1 }); 12 | -------------------------------------------------------------------------------- /t/u_re_sd.t: -------------------------------------------------------------------------------- 1 | use Graph::Directed ; 2 | use strict; use warnings; 3 | use Test::More tests => 2; 4 | 5 | my $g0 = Graph::Directed->new() ; 6 | 7 | $g0->add_weighted_edge('A', 'A1', 1) ; 8 | $g0->add_weighted_edge('A', 'A2', 1) ; 9 | $g0->add_weighted_edge('A1', 'A2', 1) ; 10 | $g0->add_weighted_edge('A2', 'A1', 1) ; 11 | $g0->add_weighted_edge('A1', 'L1', 100) ; 12 | $g0->add_weighted_edge('A2', 'L2', 100) ; 13 | $g0->add_weighted_edge('L1', 'B1', 100) ; 14 | $g0->add_weighted_edge('L2', 'B2', 100) ; 15 | $g0->add_weighted_edge('B1', 'B', 1) ; 16 | $g0->add_weighted_edge('B2', 'B', 2) ; 17 | $g0->add_weighted_edge('B1', 'B2', 1) ; 18 | $g0->add_weighted_edge('B2', 'B1', 1) ; 19 | 20 | my $SSSP0 = $g0->SPT_Dijkstra(first_root=>'A') ; 21 | 22 | is($SSSP0, "A-A1,A-A2,A1-L1,A2-L2,B1-B,L1-B1,L2-B2"); 23 | 24 | my $g1 = Graph::Directed->new() ; 25 | 26 | $g1->add_weighted_edge('A', 'A1', 1) ; 27 | $g1->add_weighted_edge('A', 'A2', 1) ; 28 | $g1->add_weighted_edge('A1', 'A2', 1) ; 29 | $g1->add_weighted_edge('A2', 'A1', 1) ; 30 | $g1->add_weighted_edge('A1', 'L1', 100) ; 31 | $g1->add_weighted_edge('A2', 'L2', 100) ; 32 | $g1->add_weighted_edge('L1', 'B3', 100) ; 33 | $g1->add_weighted_edge('L2', 'B2', 100) ; 34 | $g1->add_weighted_edge('B3', 'B', 1) ; 35 | $g1->add_weighted_edge('B2', 'B', 2) ; 36 | $g1->add_weighted_edge('B3', 'B2', 1) ; 37 | $g1->add_weighted_edge('B2', 'B3', 1) ; 38 | 39 | my $SSSP1 = $g1->SPT_Dijkstra(first_root=>'A') ; 40 | 41 | is($SSSP1, "A-A1,A-A2,A1-L1,A2-L2,B3-B,L1-B3,L2-B2"); 42 | 43 | 44 | -------------------------------------------------------------------------------- /t/u_ro_ra.t: -------------------------------------------------------------------------------- 1 | use Graph::Undirected; 2 | use strict; use warnings; 3 | use Test::More tests => 2; 4 | 5 | my $g = Graph::Undirected->new; 6 | 7 | # example graph #1 from http://mathworld.wolfram.com/GraphRadius.html 8 | # 9 | # A 10 | # | 11 | # B 12 | # / | \ 13 | # C D E 14 | # | | 15 | # F G 16 | 17 | $g->add_edge( split //, $_ ) 18 | for qw[ AB BC BD BE CF EG ]; 19 | 20 | my $apsp = $g->all_pairs_shortest_paths; 21 | 22 | is( $apsp->radius, 2, "radius" ); 23 | 24 | is_deeply( [$apsp->center_vertices], ["B"], "center_vertices" ); 25 | -------------------------------------------------------------------------------- /t/u_sc_me.t: -------------------------------------------------------------------------------- 1 | # rt.cpan.org #41190: add_edge_by_id on multigraph malfunctioning 2 | 3 | use strict; 4 | 5 | use Test::More tests => 4; 6 | 7 | use Graph; 8 | 9 | my $G0 = Graph->new(undirected => 1, 10 | vertices => ["v0", "v1", "v2"], 11 | multiedged => 1); 12 | $G0->add_edge_by_id("v0", "v1", "0"); 13 | 14 | is($G0, "v0=v1,v2"); 15 | 16 | my $G1 = Graph->new(undirected => 1, 17 | vertices => ["v0", "v1", "v2"], 18 | multiedged => 1); 19 | $G1->add_edge_by_id("v0", "v1", "1"); 20 | 21 | is($G1, "v0=v1,v2"); 22 | 23 | my $G2 = Graph->new(undirected => 1, 24 | vertices => ["v0", "v1", "v2"], 25 | multiedged => 1); 26 | $G2->add_edge_by_id("v0", "v0", "0"); 27 | 28 | is($G2, "v0=v0,v1,v2"); 29 | 30 | my $G3 = Graph->new(undirected => 1, 31 | vertices => ["v0", "v1", "v2"], 32 | multiedged => 1); 33 | $G3->add_edge_by_id("v0", "v0", "1"); 34 | 35 | is($G3, "v0=v0,v1,v2"); 36 | 37 | -------------------------------------------------------------------------------- /t/u_te_ea.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; use warnings; 3 | use Graph; 4 | use Test::More; 5 | plan tests => 4; 6 | 7 | my $graph = Graph->new( undirected => 1 ); 8 | 9 | $graph->add_vertex("Berlin"); 10 | $graph->add_vertex("Bonn"); 11 | $graph->add_edge("Berlin","Bonn"); 12 | is ("$graph","Berlin=Bonn"); 13 | $graph->set_edge_attributes("Berlin", "Bonn", { color => "red" }); 14 | is ("$graph","Berlin=Bonn"); 15 | 16 | $graph = Graph->new( undirected => 1 ); 17 | 18 | $graph->add_vertex("Berlin"); 19 | $graph->add_vertex("Bonn"); 20 | $graph->add_edge("Bonn","Berlin"); 21 | is ("$graph","Berlin=Bonn"); 22 | $graph->set_edge_attributes("Bonn", "Berlin", { color => "red" }); 23 | is ("$graph","Berlin=Bonn"); 24 | 25 | 26 | -------------------------------------------------------------------------------- /t/u_te_me.t: -------------------------------------------------------------------------------- 1 | use Graph; 2 | use strict; 3 | 4 | use Test::More tests => 18; 5 | 6 | my $g0 = Graph->new (multiedged => 1); 7 | 8 | for my $i (0..2) { 9 | print "# Adding 'A' - 'B'\n"; 10 | my $id = $g0->add_edge_get_id('A', 'B'); 11 | is($id, $i, "id is $i"); 12 | 13 | my @ids = sort { $a <=> $b } $g0->get_multiedge_ids('A', 'B'); 14 | print "# ids = @ids\n"; 15 | for my $j (0..$i) { 16 | is($ids[$j], $j, "id[$j] is $j"); 17 | } 18 | } 19 | 20 | my $g1 = Graph->new (multivertexed => 1); 21 | 22 | for my $i (0..2) { 23 | print "# Adding 'C'\n"; 24 | my $id = $g1->add_vertex_get_id('C'); 25 | is($id, $i, "id is $i"); 26 | 27 | my @ids = sort { $a <=> $b } $g1->get_multivertex_ids('C'); 28 | print "# ids = @ids\n"; 29 | for my $j (0..$i) { 30 | is($ids[$j], $j, "id[$j] is $j"); 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /util/cover.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ex 4 | 5 | perl -MDevel::Cover -e 1 || exit 1 6 | 7 | cover -delete 8 | env HARNESS_PERL_SWITCHES=-MDevel::Cover make test 9 | cover 10 | perl -wIlib -MPod::Coverage=Graph -e1 | tee podcoverage.out 11 | 12 | exit 0 13 | -------------------------------------------------------------------------------- /util/grand.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Graph; 3 | use Time::HiRes qw(time); 4 | use Getopt::Long; 5 | 6 | my %OPT = (seed => 42, test => 'apsp', fill => 0.50, V => 20, directed => 1, unionfind => 0); 7 | my %TEST2METHOD = ( 8 | apsp => 'APSP_Floyd_Warshall', 9 | mstk => 'MST_Kruskal', 10 | mstp => 'MST_Prim', 11 | sptd => 'SPT_Dijkstra', 12 | sptb => 'SPT_Bellman_Ford', 13 | cc => 'connected_components', 14 | bcc => 'biconnected_components', 15 | scc => 'strongly_connected_components', 16 | succ => sub { my $g = shift; $g->successors($_) for $g->vertices }, 17 | ef => sub { my $g = shift; $g->edges_from($_) for $g->vertices }, 18 | ea => sub { my $g = shift; $g->edges_at($_) for $g->vertices }, 19 | ); 20 | my %WTEST; @WTEST{qw(apsp mstp mstk sptd sptb)} = (); 21 | my %UTEST; @UTEST{qw(mstk mstp cc bcc)} = (); 22 | my %DTEST; @DTEST{qw(scc)} = (); 23 | 24 | sub usage { 25 | die <<__EOF__; 26 | $0: Usage: $0 [--seed=n] 27 | [--test=@{[join('|', sort keys %TEST2METHOD)]}] 28 | [--directed=d] [--fill=f] [V] 29 | Default values:@{[ map qq{\n$_ = $OPT{$_}}, sort keys %OPT ]} 30 | __EOF__ 31 | } 32 | 33 | $| = 1; 34 | usage() unless GetOptions( 35 | 'seed=n' => \$OPT{seed}, 36 | 'test=s' => \$OPT{test}, 37 | 'directed=n' => \$OPT{directed}, 38 | 'fill=f' => \$OPT{fill}, 39 | 'uf=n' => \$OPT{unionfind}, 40 | ); 41 | $OPT{V} = shift if @ARGV; 42 | usage() if @ARGV; 43 | usage() unless $TEST2METHOD{$OPT{test}}; 44 | 45 | print "Running $OPT{test}...\n"; 46 | 47 | srand($OPT{seed}); 48 | 49 | if (exists $UTEST{$OPT{test}} && $OPT{directed}) { 50 | $OPT{directed} = 0; 51 | print "($OPT{test} needs undirected, fixed)\n"; 52 | } elsif (exists $DTEST{$OPT{test}} && !$OPT{directed}) { 53 | $OPT{directed} = 1; 54 | print "($OPT{test} needs directed, fixed)\n"; 55 | } 56 | 57 | if ($OPT{fill} < 0.0 || $OPT{fill} > 1.0) { 58 | $OPT{fill} = 0.5; 59 | print "($OPT{fill} must be between 0.0 and 1.0, fixed to be 0.5)\n"; 60 | } 61 | 62 | # Thanks to Devel::DProf and List::Util breakage. 63 | # my $g = Graph->random_graph(vertices => $OPT{V}, 64 | # directed => $OPT{directed}, 65 | # edges_fill => $OPT{fill}); 66 | my $E = int(($OPT{V} * ($OPT{V} - 1) * $OPT{fill}) / ($OPT{directed} ? 1 : 2)); 67 | my $g = Graph->new(map +($_ => $OPT{$_}), qw(directed unionfind)); 68 | my $e = $E; 69 | my (%v1_v2, @edges); 70 | my $t0_edge = time(); 71 | while (1) { 72 | my $u = int(rand($OPT{V})); 73 | my $v = int(rand($OPT{V})); 74 | if ($u ne $v && !exists $v1_v2{$u}{$v}) { 75 | push @edges, [$u, $v]; 76 | $v1_v2{$u}{$v} = undef; 77 | last unless --$e; 78 | } 79 | } 80 | 81 | if (exists $WTEST{$OPT{test}}) { 82 | push @$_, rand() for @edges; 83 | $g->add_weighted_edges(map @$_, @edges); 84 | } else { 85 | $g->add_edges(@edges); 86 | } 87 | my $t1_edge = time(); 88 | printf "%d vertices, %d edges - set up %.2f\n", $OPT{V}, $E, $t1_edge - $t0_edge; 89 | 90 | my $t0 = time(); 91 | my ($u0, $s0) = times(); 92 | () = $g->${ \$TEST2METHOD{$OPT{test}} }; 93 | my $t1 = time(); 94 | my ($u1, $s1) = times(); 95 | 96 | my $u = $u1 - $u0; 97 | my $s = $s1 - $s0; 98 | my $c = $u + $s; 99 | 100 | printf "real %.2f user %.2f system %.2f cpu %.2f\n", $t1 - $t0, $u, $s, $c; 101 | 102 | exit(0); 103 | -------------------------------------------------------------------------------- /util/size.pl: -------------------------------------------------------------------------------- 1 | use lib 'lib'; 2 | use strict; use warnings; 3 | use Graph; 4 | use Devel::Size qw(size total_size); 5 | 6 | my $N = 65536; 7 | 8 | my $fmt = "%5s %8s %9s\n"; 9 | my $fmr = "%5d %8d %9.1f\n"; 10 | 11 | for ([0, 0], [0, 1], [1, 0], [1, 1]) { 12 | my ($countv, $counte) = @$_; 13 | my %args = ( 14 | countvertexed => $countv, 15 | countedged => $counte, 16 | ); 17 | printf $fmt, "V", "S", "S/N"; 18 | my $g0 = Graph->new(%args); 19 | my $s0 = total_size($g0); 20 | printf $fmr, 0, $s0, 0; 21 | my $vr; 22 | for (my $n = 1; $n <= $N; $n *= 16) { 23 | my $g0 = Graph->new(%args); 24 | $g0->add_vertices(1..$n); 25 | my $s = total_size($g0); 26 | $vr = ($s - $s0) / $n; 27 | printf $fmr, $n, $s, $vr; 28 | } 29 | printf "Vertices(countvertexed=$countv) / MB = %8.1f\n", 1048576/$vr; 30 | 31 | printf $fmt, "E", "S", "S/N"; 32 | my $g1 = Graph->new; 33 | printf $fmr, 0, $s0, 0; 34 | 35 | my $er; 36 | for (my $n = 1; $n <= $N; $n *= 16) { 37 | my $g1 = Graph->new(%args); 38 | $g1->add_edges(map [0, $_], 1..$n); 39 | my $s = total_size($g1); 40 | $er = ($s - $s0 - $n * $vr) / $n; 41 | printf $fmr, $n, $s, $er; 42 | } 43 | printf "Edges(countedged=$counte) / MB = %8.1f\n", 1048576/$er; 44 | } 45 | -------------------------------------------------------------------------------- /util/srand.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | env PERL_HASH_SEED= PERL_HASH_SEED_DEBUG=1 make test 3 | -------------------------------------------------------------------------------- /xt/manifest.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use ExtUtils::Manifest; 5 | 6 | unless ( $ENV{RELEASE_TESTING} ) { 7 | plan( skip_all => "Author tests not required for installation" ); 8 | } 9 | plan tests => 2; 10 | 11 | is_deeply [ ExtUtils::Manifest::manicheck() ], [], 'missing'; 12 | is_deeply [ ExtUtils::Manifest::filecheck() ], [], 'extra'; 13 | -------------------------------------------------------------------------------- /xt/pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | eval "use Test::Pod::Coverage 1.00"; 4 | plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; 5 | plan tests => 1; 6 | pod_coverage_ok("Graph"); 7 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use Test::More; 3 | eval "use Test::Pod 1.00"; 4 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 5 | all_pod_files_ok(); 6 | --------------------------------------------------------------------------------