tsort

#!/usr/bin/perl

=begin metadata

Name: tsort
Description: topological sort
Author: Jeffrey S. Haemer
License: perl

=end metadata

=cut

use strict;

use File::Basename qw(basename);
use Getopt::Std qw(getopts);

use constant EX_SUCCESS => 0;
use constant EX_FAILURE => 1;

my $Program = basename($0);

my %opt;
getopts('bd', \%opt) or usage();
usage() if ($opt{'b'} && $opt{'d'});

my $file = shift @ARGV;
if (@ARGV) {
    warn "$Program: extra operand '$ARGV[0]'\n";
    usage();
}
$file = '-' if (!defined($file));

my $fh;
if ($file eq '-') {
    $fh = *STDIN;
} else {
    if (-d $file) {
        warn "$Program: '$file' is a directory\n";
        exit EX_FAILURE;
    }
    unless (open $fh, '<', $file) {
        warn "$Program: '$file': $!\n";
        exit EX_FAILURE;
    }
}

my %pairs;	# all pairs ($l, $r)
my %npred;	# number of predecessors
my %succ;	# list of successors
my @input;

while (<$fh>) {
    next unless m/\w/;
    s/\A\s+//;
    s/\s+\z//;
    my @l = split;
    push @input, @l if scalar(@l);
}
if (scalar(@input) % 2 == 1) {
    warn "$Program: odd number of tokens\n";
    exit EX_FAILURE;
}
while (@input) {
    my $l = shift @input;
    my $r = shift @input;
    next if defined $pairs{$l}{$r};
    $pairs{$l}{$r}++;
    $npred{$l} += 0;
    ++$npred{$r};
    push @{$succ{$l}}, $r;
}

# create a list of nodes without predecessors
my @list = grep {!$npred{$_}} keys %npred;

while (@list) {
    $_ = pop @list;
    print "$_\n";
    foreach my $child (@{$succ{$_}}) {
	if ($opt{'b'}) {	# breadth-first
	    unshift @list, $child unless --$npred{$child};
	} else {	# depth-first (default)
	    push @list, $child unless --$npred{$child};
	}

    }
}

warn "$Program: cycle detected\n" if grep {$npred{$_}} keys %npred;
unless (close $fh) {
    warn "$Program: failed to close input: $!\n";
    exit EX_FAILURE;
}
exit EX_SUCCESS;

sub usage {
    warn "usage: $Program [-b|-d] [filename]\n";
    exit EX_FAILURE;
}

=head1 NAME

tsort - topological sort

=head1 SYNOPSIS

  tsort [filename]

=head1 DESCRIPTION

=over 2

Does a topological sort of input pairs.

For a more complete description, see the tsort(1) man page,
For an explanation of the algorithm,
see the I<Work> column in the October, 1998, issue of SunExpert,
or the references given below.

=back

=head1 OPTIONS AND ARGUMENTS

=over 8

=item B<[-b|-d]>

breadth-first or depth-first (default) traversal

=item B<filename>

Optional input file.
Input format is pairs of white-space-separated fields.
Each field is the name of a node.
Output is the topologically sorted list of nodes.

=back

=head1 AUTHOR

  Jeffrey S. Haemer

=head1 SEE ALSO

tsort(1), tcsh(1), tchrist(1)

Algorithm stolen from Jon Bentley (I<More Programming Pearls>, pp. 20-23),
who, in turn, stole it from Don Knuth
(I<Art of Computer Programming, volume 1: Fundamental Algorithms>,
Section 2.2.3)

=cut