diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..7330f3a --- /dev/null +++ b/.travis.yml @@ -0,0 +1,12 @@ +os: + - linux + - osx +language: perl6 +perl6: + - latest +install: + - rakudobrew build-panda + - panda --notests installdeps . +script: + - PERL6LIB=$PWD/lib prove -e perl6 -v t/ +sudo: false \ No newline at end of file diff --git a/META6.json b/META6.json new file mode 100644 index 0000000..1ee760d --- /dev/null +++ b/META6.json @@ -0,0 +1,18 @@ +{ + "authors" : [ + "Richard Hainsworth aka finanalyst" + ], + "build-depends" : [], + "depends" : [], + "description" : "A perl6 implementation of the Tarjan algorithm", + "name" : "Algorithm::Tarjan", + "perl" : "6.c", + "provides" : { + "Algorithm::Tarjan" : "lib/Algorithm/Tarjan.pm6" + }, + "resources" : [], + "source-url" : "git://github.com/finanalyst/p6-Algorithm-Tarjan.git", + "test-depends" : , + "version" : "0.01", + "license": "Artistic" +} \ No newline at end of file diff --git a/lib/Algorithm/Tarjan.pm b/lib/Algorithm/Tarjan.pm new file mode 100644 index 0000000..877b704 --- /dev/null +++ b/lib/Algorithm/Tarjan.pm @@ -0,0 +1,85 @@ +#!/usr/bin/env perl6 +# implementation of Tarjan's algorithm in perl6 +# uses pseudo code from https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm + +# various possibilities for how to describe a graph. +# The init method can be over-ridden to change the map the user's structure into the array structure here. +# Here init method assumes that we have a hash of nodes pointing to an array of children. +# If a node is included in an array of children, but is not in the original hash, it is added to the hash with no children. +use v6.c; + +class Algorithm::Tarjan::Node { + has @.succ is rw = (); + has $.name; + has $.index is rw; + has $.low-link is rw; + has Bool $.on-stack is rw = False; +} + +class Algorithm::Tarjan { + has Algorithm::Tarjan::Node %!nodes; + has $!main-index; + has @!stack; + has @.strongly-connected; + has Bool $!run-once; + + method init( %h ) { + %!nodes = (); + $!main-index = 0; + @!stack = (); + @.strongly-connected = (); + $!run-once = False; + for %h.kv -> $nd, @children { # stringifies all inputs + %!nodes{ $nd } = Algorithm::Tarjan::Node.new( + :name( ~$nd ), + :succ( @children.map( { ~$_ } ) ) + ); + }; + # adds children not in node set + for %!nodes.values -> $node { + for $node.succ>>.grep( { ! (%!nodes{$_}:exists).so } ).flat { + %!nodes{$_} = Algorithm::Tarjan::Node.new( :name($_) ) + } + } + }; + + method strong-components { + return if $!run-once; + for %!nodes.values -> $node { + $.strong-connect($node) unless $node.index.defined + }; + $!run-once = True; + } + + method strong-connect( Algorithm::Tarjan::Node $v ) { + $v.index = $v.low-link = $!main-index++; + @!stack.push: $v; + $v.on-stack = True; + for $v.succ -> $w { + my $wn = %!nodes{$w}; + if ( ! $wn.index.defined ) { + $.strong-connect( $wn ); + $v.low-link = min( $v.low-link, $wn.low-link ); + } elsif $wn.on-stack { + $v.low-link = min( $v.low-link, $wn.index ); + } + } + my Algorithm::Tarjan::Node $w; + my @scc = (); + if $v.index == $v.low-link { + repeat { + $w = @!stack.pop; + $w.on-stack = False; + @scc.push: $w.name; + } until $w.name eq $v.name; + @!strongly-connected.push( @scc.sort.join(',') ) if @scc.elems > 1; + } + } + + method find-cycles { + $.strong-components(); + @!strongly-connected.elems + } +} + + diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..e8b74d0 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,93 @@ +use v6; +use Test; + +use Algorithm::Tarjan; + +my Algorithm::Tarjan $a .= new(); + +isa-ok $a, Algorithm::Tarjan, 'module loads'; + +my %h = ( + a => , + b => , + c => , + d => (), + e => (), + f => (), + g => , + h => (), + i => (), + j => (), + k => (), + l => (), + m => () +); +lives-ok { $a.init( %h ) }, 'test graph, no cycles loads'; +lives-ok { $a.strong-components()}, 'get strong components without dying'; +is-deeply $a.strongly-connected.flat, (), 'trivial list of strong components'; + +%h = ( + a => , + b => , + c => , + d => (), + e => (), + f => (), + g => +); +lives-ok { $a.init( %h ) }, 'test graph, no cycles loads, but missing nodes in hash'; +$a.strong-components(); +is-deeply $a.strongly-connected.flat, (), 'trivial list of strong components'; +is $a.find-cycles, 0, 'no cycles in graph'; + +%h = ( + a => , + b => , + c => , + d => (), + e => (), + f => (), + g => , + h => (), + i => (), + j => (), + k => (), + l => (), + m => ('a', ) +); +$a.init( %h ); +$a.strong-components(); +is-deeply $a.strongly-connected.list, ['a,b,c,g,m'], 'list of strong components in graph'; +is $a.find-cycles, 1, 'A cycle in graph'; + +%h = ( + a => ('b', ), + b => ('c', ), + c => ('a', ), + d => , + e => , + f => , + g => ('f',), + h => +); +$a.init( %h ); +$a.strong-components(); +is-deeply $a.strongly-connected.list, ['a,b,c', 'f,g', 'd,e'], 'deals with graph in Wikipedia article'; +is $a.find-cycles, 3, 'Three cycles in graph'; + +%h = ( + MinModel => , + a => , + a1 => (), + b => ('b1',), + b1 => , + b2 => , + b3 => (), + b4 => (), + b5 => (), + c => ('c1',), + c1 => , + c2 => () +); + +done-testing();