Problems with sorting

[Tanktalus]

I have many (sometimes more than 100) tasks to perform in perl. Some of these tasks are concerned with order (task a must complete before task c, for example). Others may not care about order (independant of other tasks). There are no loops (e.g., a may require c, but c may not require a, even indirectly). Note that there is more than one possible solution to this. I'm not concerned with "best" (I can't even define "best"). I'm merely concerned with coming up with a valid solution, one that, given the same input (same list of tasks, same requirements) gives the same list (the reason for this is a bit complex, so I won't get into that just now).

I'm trying to come up with a way to get sort to do this. Really, I'm not concerned with having to use sort, but I was thinking sort would be the easy way to do this. It doesn't seem to be. Here is a completely rewritten example of what I'm doing (the original code is thousands of lines long and proprietary).

use strict;
use Data::Dumper;

my %before =
    (
     a => _s(qw(c)),
     b => _s(qw(d e)),
     c => _s(qw(l)),
     d => _s(qw(e a)),
     e => _s(qw(c)),
     f => _s(qw(g d)),
     g => _s(qw(c)),
     h => _s(qw(g i)),
     i => _s(qw()),
     j => _s(qw(c)),
     k => _s(qw()),
     l => _s(qw()),
     n => _s(qw(c)),
     o => _s(qw()),
    );

print Dumper(\%before);

my @order = sort {
    #print "Checking $a vs $b\n";
    prereq($a, $b) <=> prereq($b, $a)
} keys %before;

print "@order\n";

sub prereq
{
    my ($l, $r) = @_;

    if (exists $before{$l}{$r})
    {
        return 1;
    }
    if (grep { prereq($_, $r) } keys %{$before{$l}})
    {
        return 1;
    }
    0;
}

# setup - create a hash for easy access
sub _s
{
    my %h = map { $_ => 1 } @_;
    \%h
}

The output is:

l c e n a d j k g h b f o i

I'm expecting that "h" should come after "i" (since h requires i). However, if I uncomment the print in the sort, I notice that h and i aren't even compared.

I originally noticed this problem on AIX using perl 5.8.0, and the above code was tested using Linux perl 5.8.5. For many reasons, perl 5.8 is a requirement (XML::Twig works better with 5.8 than 5.6).

[kvale]

What you want here is called a topological sort. First create a directed dependency graph of tasks and then apply a topological sort to that graph to produce an ordered list of tasks. Happily, there is a module Sort::Topological that accomplishes this task:

my %children = (
                  'a' => [ 'b', 'c' ],
                  'c' => [ 'x' ],
                  'b' => [ 'x' ],
                  'x' => [ 'y' ],
                  'y' => [ 'z' ],
                  'z' => [ ],
                  );
sub children { @{$children{$_[0]} || []}; } 
my @unsorted = ( 'z', 'a', 'x', 'c', 'b', 'y' );
my @sorted = toposort(\&children, \@unsorted);

%children gives the dependency graph, and the sub children takes care of the null case.

[Tanktalus]

Thank you - that looks extremely promising. I really, really like that it uses a call-back to get the dependancies rather than asking for a complete list of dependancies up front. Since S::T has to loop through everything anyway, why loop through it in the calling code, too, when a callback will implicitly perform the loop?

It does seem to perform the sort in the reverse order of what I wanted, but thankfully perl makes that pretty darned trivial.

For posterity, my example has changed to:

use Sort::Topological;

use strict;
use Data::Dumper;

my %before =
    (
     a => _s(qw(c)),
     b => _s(qw(d e)),
     c => _s(qw(l)),
     d => _s(qw(e a)),
     e => _s(qw(c)),
     f => _s(qw(g d)),
     g => _s(qw(c)),
     h => _s(qw(g i)),
     i => _s(qw()),
     j => _s(qw(c)),
     k => _s(qw()),
     l => _s(qw()),
     n => _s(qw(c)),
     o => _s(qw()),
    );

# print Dumper(\%before);

my @order = reverse
    Sort::Topological::toposort(
                                sub {
                                    @{$before{$_[0]}};
                                },
                                [ keys %before ],
                               );

print "@order\n";

sub _s
{
    [ @_ ]; #my %h = map { $_ => 1 } @_;
    #\%h
}

And the result is:

l c a e i g d o f b h k j n

At this point, this (simple) example is working. Which gives me reasonable confidence since I did manage to create a non-working example in the first place. Again, thanks!

The only issue is that the module drags in too much - too bad it wasn't separated out into its own distribution. Oh well, can't win 'em all!

[Limbic~Region]

Tanktalus,
You might find some of the answers I got to Priority Sorting Challenge useful.

[eyepopslikeamosquito]

For more fun, as brilliantly exploited by Jukka Suomela in TPR(0,4b), notice that perl itself has a built-in topological sorter: the garbage collector. Chris Dolan's explanation can be found here.

[Tanktalus]

That looks entertaining ... but I'm not sure I would want to rely on it for production code. First off, I can't quite get my head around the code. Even the de-obfuscated version. (I'm not entirely sure if this will work in a larger program, or if it only works in a standalone perl VM, for example.) Secondly, I'm not sure if PONIE will support this type of GC or not. I'm hoping that lots of this code will survive into Perl6, and Sort::Topological looks more likely to make that jump.

But, thanks for the ever-present extra WTDI. :-)

[TedPride]

This took me a little while to figure out how to solve, but it's really very easy. While there are still items to order, look for items that come before only items that have already been ordered. Insert them at start (or at end and reverse, like I did). The algorithm is at worst case about (N^2) / 2, efficient enough for the task given here.

use strict;
use warnings;

my %before = (
    a => ['c'],
    b => ['d','e'],
    c => ['l'],
    d => ['e','a'],
    e => ['c'],
    f => ['g','d'],
    g => ['c'],
    h => ['g','i'],
    i => [],
    j => ['c'],
    k => [],
    l => [],
    n => ['c'],
    o => [],
);

my ($k, $m, %p, @order);
while (scalar keys %before) {
    for $k (keys %before) {
        $m = 1;
        for (@{$before{$k}}) {
            if (!exists $p{$_}) {
                $m = 0; last;
            }
        }
        if ($m) {
            push(@order, $k);
            $p{$k} = ();
            delete($before{$k});
        }
    }
}
@order = reverse @order;
print @order;