view release on metacpan or  search on metacpan

lib/Algorithm/TSort.pm  view on Meta::CPAN

# vim: ft=perl sts=4 ts=8 sw=4 et ff=unix
package Algorithm::TSort;
use 5.007003;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Algorithm::TSort ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	tsort
	Graph	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( tsort );

our $VERSION = '0.05';
{
    package Algorithm::TSort::ADJ;
    sub adj_nodes {
        my $self = shift;
        my $node = shift;
        for ( $self->{$node} ) {
            return @$_ if ref;
        }
        return ();
    }

    sub nodes {
        return keys %{ $_[0] };
    }
    package Algorithm::TSort::ADJSUB;
    sub adj_nodes {
        my $self = shift;
        my $node = shift;
        return $$self->($node);
    }
    package Algorithm::TSort::ADJSUB_ARRAYREF;
    sub adj_nodes {
	my $array = $_[0]->( $_[1] );
	return $array ? @$array : ();
    }
    package Algorithm::TSort::Guard;
    sub new{
	return bless $_[1], $_[0];
    }
    sub DESTROY { $_[0]->() };
}

sub Graph($$) {
    my $what = shift;
    my $data = shift;
    die "Graph: undefined input" unless defined $what;
    if ( $what eq 'IO' || $what eq 'SCALAR' ) {
        my %c;
        my $line;
        my $fh;
        if ( $what eq 'SCALAR' ) {
            open $fh, "<", \$data;
        }
        else {
            $fh = $data;
        }
        local $/ = "\n";
        while ( defined( $line = <$fh> ) ) {
            chomp $line;
            next unless $line =~ m/\S/;
            my ( $node, @deps ) = split ' ', $line;
            $c{$node} = \@deps;
        }
        return bless \%c, 'Algorithm::TSort::ADJ';
    }
    elsif ( $what eq 'ADJSUB' ) {
        return bless \( my $s = $data ), 'Algorithm::TSort::ADJSUB';
    }
    elsif ( $what eq 'ADJSUB_ARRAYREF' ) {
        return bless $data, 'Algorithm::TSort::ADJSUB_ARRAYREF';
    }
    elsif ( $what eq 'ADJ' ) {
        my %c = %$data;
        return bless \%c, 'Algorithm::TSort::ADJ';
    }
    else {
        require Carp;
        Carp::croak("Graph: don't know about \$what='$what'");
    }
}


# Preloaded methods go here.
sub tsort($;@) {
    my $object = shift;
    my @nodes  = @_;
    my @sorted;
    my %seen;
    my $req_sub;
    my $guard;
    unless (@nodes) {
        if ( UNIVERSAL::can( $object, 'nodes') ) {
            @nodes = $object->nodes();
        }
        else {
            require Carp;
            Carp::croak("tsort: no nodes for sort");
        }
    }
    $guard = Algorithm::TSort::Guard->new(sub {
	$req_sub = undef; # remove circular dependency;
    });


    $req_sub = sub {
        my $node = shift;
        if ( $seen{$node} ) {
            die "Algorithm::TSort - can't tsort cicle detected" if ( $seen{$node} == 1 );
            return;
        }
        $seen{$node} = 1;
        for ( $object->adj_nodes($node) ) {
            $req_sub->($_);
        }
        $seen{$node} = 2;
        push @sorted, $node;
    };

    for (@nodes) {
        next if $seen{$_};
        $req_sub->($_);
    }
    return reverse @sorted;
}

1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Algorithm::TSort - Perl extension for topological sort

=head1 SYNOPSIS