Perl 学习元素的顺序

我想找到一种有效的方法（最好是用Perl），通过比较单词在组的多个子集中的顺序来学习单词族的固定顺序。 （它们是作业参数。大约有30个不同的参数。不同的作业需要不同的参数组合&每个作业中只有几个参数）

例如，假设：

first
second
third
sixth
seventh
tenth

first
third
fourth
fifth
sixth

third
fifth
seventh
eighth
ninth
tenth

它应该能够记住它看到的相对顺序关系，从而确定顺序是：

first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth

我生成了如下列表：

first.second.third.sixth.seventh.tenth
first.third.fourth.fifth.sixth
third.fifth.seventh.eighth.ninth.tenth

然后按字母顺序进行唯一排序并进行直观比较，但我有数百种不同的30ish参数组合，所以对所有参数进行排序并手动将它们组合在一起将是一项艰巨的工作

我认为@daniel tran已经回答了其中的“如何”问题，并使用了一些黑客技术，如：

$order->{$prev}->{$this} = 1;
$order->{$this}->{$prev} = 0;

我已经设法为每对连续参数填充一个哈希值，用1或0表示哪一个先出现，如：

$VAR1 = {
    'first' => {
        'second' => 1,
        'third' => 1,
    },
    'second' => {
        'first' => 0,
        'third' => 1,
    },
    'third' => {
        'first' => 0,
        'second' => 0,
        'fourth' => 1,
        'fifth'  => 1,
        'sixth'  => 1,
    },            
    'fourth' => {
        'third' => 0,
        'fifth' => 1,
    },
    ...

但是，当我的排序函数被要求对一对从未被视为近邻的对象进行排序，因此没有定义关系时，我想知道在排序函数中应该做什么

有简单的解决办法吗？ 我这样做对吗？ 首先有更好的WTDI吗

谢谢

---

John

您使用图形和拓扑排序链接到的问题。该模块非常易于使用：

use warnings;
use strict;
use Graph;

my $graph = Graph->new(directed => 1);
my $prev;
while (<DATA>) {
    chomp;
    $graph->add_edge($prev, $_) if length && length $prev;
    $prev = $_;
}
print $_,"\n" for $graph->topological_sort;

__DATA__
first
second
third
sixth
seventh
tenth

first
third
fourth
fifth
sixth

third
fifth
seventh
eighth
ninth
tenth

---

我试图自己实现一个简单的解决方案。我构建了

%order

散列，其中每个键的值都是它后面的元素。然后我创建了该结构的传递闭包（即，如果

第一个

在

第二个

之前，

第二个

在

第三个

之前，那么

第一个

必须在

第三个

之前）。如果有足够的信息，每个键将有不同数量的值，根据值的数量对元素进行排序将得到有序列表

#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

my @partial = (
    [qw[ first second third sixth seventh tenth ]],
    [qw[ first third fourth fifth sixth ]],
    [qw[ third fifth seventh eighth ninth tenth ]]);

my %order;
my %all;
for my $list (@partial) {
    undef @all{ @$list };
    undef $order{ $list->[ $_ - 1 ] }{ $list->[$_] }
        for 1 .. $#$list;
}

my $changed = 1;
while ($changed) {
    undef $changed;
    for my $from (keys %order) {
        if (my @to = keys %{ $order{$from} }) {
            if (my @to2 = map keys %{ $order{$_} }, @to) {
                my $before = keys %{ $order{$from} };
                undef @{ $order{$from} }{@to2};
                $changed = 1 if $before != keys %{ $order{$from} };
            }
        }
    }
}

my %key_counts;
$key_counts{ keys %{ $order{$_} } }++ for keys %order;
warn "Not enough information\n"
    if keys %key_counts != keys %order;

say join ' ',
    sort { keys %{ $order{$b} } <=> keys %{ $order{$a} } }
    keys %order;

---

这是一个直接而简单的手动解决方案

它收集给定子序列中的所有元素并对它们进行排序。排序标准是比较元素在第一个子序列中的位置（索引），该子序列具有两个元素。如果没有一个子序列同时包含两个元素，则从排序块返回一个未确定（零）

use warnings;
use strict;
use feature 'say';    
use List::MoreUtils qw(uniq firstval);

my @all = qw(ant bug frog cat dog elk);  # to draw input (sublists) from

my @s1 = @all[0,1,3,5];
my @s2 = @all[1,2,4,5];
my @s3 = @all[2,3,4];

my @inv = (                              # for index comparison
    { map { $s1[$_] => $_ } 0..$#s1 },  
    { map { $s2[$_] => $_ } 0..$#s2 },  
    { map { $s3[$_] => $_ } 0..$#s3 } 
);

my @sorted = sort { 
    my $fv = firstval { exists $_->{$a} and exists $_->{$b} } @inv;
    ($fv) ? $fv->{$a} <=> $fv->{$b} : 0;
} uniq @s1, @s2, @s3;

say "@sorted";

first second third fourth fifth sixth seventh eighth ninth tenth

use warnings;
use strict;
use feature 'say';    
use List::MoreUtils qw(uniq firstval);

my @all = qw(ant bug frog cat dog elk);  # to draw input (sublists) from

my @s1 = @all[0,1,3,5];
my @s2 = @all[1,2,4,5];
my @s3 = @all[2,3,4];

my @inv = (                              # for index comparison
    { map { $s1[$_] => $_ } 0..$#s1 },  
    { map { $s2[$_] => $_ } 0..$#s2 },  
    { map { $s3[$_] => $_ } 0..$#s3 } 
);

my @sorted = sort { 
    my $fv = firstval { exists $_->{$a} and exists $_->{$b} } @inv;
    ($fv) ? $fv->{$a} <=> $fv->{$b} : 0;
} uniq @s1, @s2, @s3;

say "@sorted";

my @subseqs = (\@s1, \@s2, \@s3);

my @inv;

for my $rr (@subseqs) {
    push @inv, { map { $rr->[$_] => $_ } 0..$#$rr }
}