Well, I don't know if this is a topical sort -- I kind of doubt it -- but it seems to me to give satisfactory results, and handles "loops" quite gracefully. It's pretty efficient, but doesn't necessarily give the optimal result. Pass a list of arrayrefs.
sub concensus_sort
{
my( %pre, %suf );
for my $ar ( @_ )
{
my @a = @$ar;
my @pre;
while ( @a )
{
my $k = shift @a;
$pre{$k} ||= {};
$suf{$k} ||= {};
$pre{$k}{$_}++ for @pre;
$suf{$k}{$_}++ for @a;
push @pre, $k;
}
}
if ( $main::DEBUG )
{
for ( keys %pre )
{
for my $p ( keys %{ $pre{$_} } )
{
if ( exists $pre{$p}{$_} )
{
print "$_-$p AND $p-$_ !!!\n";
}
}
}
}
my @result;
for my $k (
sort {
keys(%{$pre{$a}}) <=> keys(%{$pre{$b}})
or
keys(%{$suf{$a}}) <=> keys(%{$suf{$b}})
} keys %suf
) {
push @result, $k;
# now remove all trace of it in the data structures:
delete $pre{$_}{$k} for keys %{ $suf{$k} };
delete $suf{$_}{$k} for keys %{ $pre{$k} };
delete $pre{$k};
delete $suf{$k};
}
@result
}
But it still doesn't give a pretty result when the input lists are disjoint.