Perl 使用tsort算法可以更好地保持顺序吗？

我正在使用对库及其依赖项的列表进行排序。如果依赖项不禁止它，我希望排序顺序保持不变。此库列表中不会出现这种情况：

• 这个
• 那
• 其他[该]
• 这件事

依赖项在括号中指定

这个

和那个没有依赖关系<代码>其他取决于

那个

，而

东西

取决于

那个

和

这个

。应用

tsort

后，我希望列表输出为：

• 这个
• 那
• 其他
• 东西

订单不变。我得到的是：

• 那
• 其他
• 这个
• 东西

这在依赖项解析方面是正确的，但无法保持原始顺序

以下是我的代码的简化版本：

#!/usr/bin/perl -w
use v5.10;

sub sortem {
    my %pairs;  # all pairs ($l, $r)
    my %npred;  # number of predecessors
    my %succ;   # list of successors

    for my $lib (@_) {
        my $name = $lib->[0];
        $pairs{$name} = {};
        $npred{$name} += 0;

        for my $dep (@{ $lib->[1] }) {
            next if exists $pairs{$name}{$dep};
            $pairs{$name}{$dep}++;
            $npred{$dep}++;
            push @{ $succ{$name} } => $dep;
        }
    }

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

    while (@list) {
        my $lib = pop @list;
        unshift @ret => $lib;
        foreach my $child (@{$succ{$lib}}) {
            push @list, $child unless --$npred{$child};
        }
    }

    if ( my @cycles = grep { $npred{$_} } @_ ) {
        die "Cycle detected between changes @cycles\n";
    }

    return @ret;
}

say for sortem(
    ['this',  []],
    ['that',  []],
    ['other', [qw(that)]],
    ['thing', [qw(that this)]],
);

如何对其进行修改以尽可能保留原始顺序

对于那些不懂Perl但只想在工作中看到它的人，请将这些行粘贴到文件中，并将文件馈送到

tsort

以获得相同的、不保留顺序的输出：

that thing
this thing
that other
that this

---

让我们这样编写最后一个循环：

while (my @list = grep { !$npred{$_} } keys %npred) {
  push(@ret, @list);  # we will change this later
  for my $lib (@list) {
    delete $npred{$lib};
    for my $child ( @{ $succ{$ib} } ) {
      $npred{$child}--;
    }
  }
}

if (%npred) {
  ...we have a loop...
}

也就是说，我们在搜索

键%npred

以查找零。当

grep

没有返回任何元素时，我们要么完成，要么有一个循环

为了使拓扑排序在某些初始排序时保持稳定，我们只需将

push（@ret，@list）

更改为：

push(@ret, sort {...} @list);

其中，

{…}

是指定初始顺序的比较函数

更新一个完整的工作示例：

use strict;
use warnings;
use Data::Dump qw/pp dd/;

my %deps = (
  # node => [ others pointing to node ]
  this => [],
  that => [],
  other => [qw/that/],
  thing => [qw/that this other/],
  yowza => [qw/that/],
);

# How to interpret %deps as a DAG:
#
# that ---> other ---+
#   |                V
#   +------------> thing
#   |                ^
#   +---> yowza      |
#                    |
# this --------------+
#
# There are two choices for the first node in the topological sort: "this" and "that".
# Once "that' has been chosen, "yowza" and "other" become available.
# Either "yowza" or "thing" will be the last node in any topological sort.

sub tsort {
  my ($deps, $order) = @_;

  # $deps is the DAG
  # $order is the preferred order of the nodes if there is a choice

  # Initialize counts and reverse links.

  my %ord;
  my %count;
  my %rdep;
  my $nnodes = scalar(keys %$deps);
  for (keys %$deps) {
    $count{$_} = 0;
    $rdep{$_} = [];
    $ord{$_} = $nnodes;
  }

  for my $n (keys %$deps) {
    $count{$n}++ for (@{ $deps->{$n} });
    push(@{$rdep{$_}}, $n) for (@{ $deps->{$n} });
  }

  for (my $i = 0; $i <= $#$order; $i++) {
    $ord{ $order->[$i] } = $i;
  }

  my @tsort;

  # pp(%$deps);
  # pp(%rdep);

  while (1) {
    # print "counts: ", pp(%count), "\n";
    my @list = grep { $count{$_} == 0 } (keys %count);
    last unless @list;
    my @ord = sort { $ord{$a} <=> $ord{$b} } @list;
    push(@tsort, @ord);
    for my $n (@list) {
      delete $count{$n};
      $count{$_}-- for (@{ $rdep{$n} });
    }
  }

  return @tsort;
}

sub main {
  my @t1 = tsort(\%deps, [qw/this that other thing yowza/]);
  print "t1: ", pp(@t1), "\n";

  my @t2 = tsort(\%deps, [qw/this that yowza other thing/]);
  print "t2: ", pp(@t2), "\n";

  my @t3 = tsort(\%deps, [qw/that this yowza other thing/]);
  print "t3: ", pp(@t3), "\n";
}

main();

---

哎呀，谢谢你的打字错误修正，@davido。我想知道你的拓扑排序是否稳定。看来并非如此。然而，在搜索该主题时，我发现几乎没有关于稳定拓扑排序的讨论。不确定您所说的“稳定”是什么意思，@DavidO。从中提取图形，“快速排序”是不稳定的，因此无法保证两个等价元素会保持彼此之间的顺序，而“合并排序”是稳定的。想象一下，仅在第二位数字上排序

a1 b2 c3 d3 e4

。合并排序将保留“c3 d3”，而快速排序可能保留也可能不保留。回到图表：拓扑排序所使用的算法似乎不稳定，因此“c3d3”可能最终会变成“d3c3”，或者根据天气情况变成“c3d3”。）好吧，它每次都以完全相同的顺序发出，只是与我最初提供列表的顺序不一样。这返回

[qw（此项的其他内容）]

，这仍然是错误的。我尝试使用

unshift

而不是

push

，得到了

[qw（这另一个东西）]，它有

那`和

这

相反：-（啊，等等，我添加了一个索引，

my%ord=do{my$I=0；map{${u->[0]=>$I++}；

，然后将

push

行更改为

unshift@ret，sort{$ord{$a}$ord{$b}@list；

这会返回正确的答案。非常有趣。我将把它插入我的实际代码中，看看它是否有效。的确，这似乎有效。谢谢@user5402！我很高兴你找到了一个解决方案！哦，不适用于不同长度的依赖项列表。示例：我希望这个输出

[qw（这是另一个东西yowza）]

，但是得到

[qw（这个另一个东西是你的）]

，取而代之的是：

说sortem（['this'，[]]，['that'，[]]，['other'，[qw（那个）]，['thing'，[qw（那个另一个）]，['yowza'，[qw（那个）]，；

t1: ("this", "that", "other", "yowza", "thing")
t2: ("this", "that", "yowza", "other", "thing")
t3: ("that", "this", "yowza", "other", "thing")