perl - 使用 tsort 算法时可以更好地保留顺序吗？

Question

我正在使用 tsort algorithm对库列表及其依赖项进行排序。在依赖项不禁止的情况下，我希望排序顺序保持不变。此库列表不会发生这种情况:

此

那个

其他 [那个]

事情[那个]

依赖项在括号中指定。 this和 that没有依赖关系。 other取决于 that , 和 thing取决于 that和 this .申请后 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

Answer 1

让我们像这样写你的最后一个循环:

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...
}

即，我们扫荡 keys %npred寻找零。当 grep不返回我们完成或循环的元素。

为了使拓扑排序稳定 w.r.t.一些初始订购，我们只是更改 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();

输出是:

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