algorithm - 比较字符串并删除 Perl 中更通用的模式

Question

我有一个字符串数组，这些数字可能由正斜杠分隔，例如754 或 754/128。这些字符串可以具有未定义的长度，换句话说:可能如下所示:1234/34/21/120/3。在数组中，我只想保留包含其他模式的更专业的模式。例如，在上面的第一个示例中，754/128 包含 754，因此可以从数组中删除 754。

这个包含的概念和人们预期的一样广泛，甚至可能更广泛:它类似于您查看有向图的方式，其中模式中的每个斜线都代表向前迈出的一步。包含的模式可以是任意长度，只要它以某种方式位于包含模式内。这意味着 small 路径可以以任何(时间顺序正确的)形式出现。例如，903/900 包含在 903/902/900 中，即使模式是“split open”。一种形象化的方法是:在小路径中，我们从 A 点走到 B 点。在较大的路径中，我们也从 A 点走到 B，但我们在 C 处停了下来。较大的路径访问更多 地方比小路还不错。因此，较小的路径可以以任何拆分形式出现——只要遵守路径的顺序即可。例如:

2/5 - 1/2/3/4/5
# included
5/2 - 1/2/3/4/5
# not included

我在这里的意思是“包含”项目的位置在大路径中应该相同。例如:1/3/2 在 1/5/3/4/2 中“匹配”，因为在小路径和大路径中顺序相同: 1 位于 3 之前的位置，而 3 又位于 2 之前的某个位置。 1/2/3、2/1/3 等将不匹配较大的路径 1/5/3/4/2即使它们是具有相同项目的有效路径。这是因为出现的顺序不同。

上面的例子还说明了小模式中的项目可以出现在大模式中的任何地方；不仅在第一个和最后一个位置或在后续位置。换句话说，1/2/3/4 的所有包含路径是:

1/2
1/2/3
1/3
1/4
2/3
2/3/4
2/4
3/4

我正在寻找一种有效的方法来删除给定数组中包含在同一数组中其他数组中的路径。

我得到了 this far ，但我不确定我应该如何有效地检查两个项目之间的包含关系。

#!/usr/bin/perl

my @arr = ("903/900", "903/902/900", "903/904/902/901", "903/904/902/908/900", "903");
my @res = ();

OUTER: for (my $i = 0; $i < @arr; $i++) {
    my $first = $arr[$i];
    my $j = $i+1;
    INNER: while($j < @arr) {
        my $second = $arr[$j];
        &compare_paths($first, $second);
        $j++;
    }
}

sub compare_paths {
    my ($first, $second) = @_;

    @first_items = split(/\//, $first);
    @second_items = split(/\//, $second);

    # Compare values from 1 and 2
}

上面代码的预期输出是

@res = ("903/904/902/901", "903/904/902/908/900");

删除原因:

• 903/900包含在903/902/900
中
• 903/902/900包含在903/904/902/908/900
• 903 包含在 903/904/902/901
中

如何有效地实现这样的算法？我的主要想法是检查 @first_items 的项目是否存在于 $second 中，如果不继续，但如果是的话检查第二个项目是否也存在并且如果是:检查它的子串位置。这必须大于第一个项目的子字符串位置。对每个项目继续(对 @second_items 和 $first 反过来)直到匹配所有字符串。 (如果有助于提高速度，可以将初始数组交换为以前一个数组为键的散列。)

Answer 1

我希望有通用算法可以解决这个问题，并且可能可以利用库。然而，这里有一个手卷的。

首先，我们根据路径中的项数对数组进行排序。然后我们向上移动该数组，将每个元素与所有更长的元素进行比较。这样每条路径都会尽早排除。

比较是在/上拆分得到的数组之间进行比较。它检查较小数组的所有元素是否作为一个精确的子序列在较大数组中，以便较大数组仅通过删除元素(不重新排列)产生较小数组。

use warnings;
use strict;

my @arr = qw(902/904 903/900 903/902/900 903/904/902/901 
             903/904/902/908/900 903);
my @sorted = sort { (split '/', $a) > (split '/', $b) } @arr;
my @primes;

OUTER:
for my $i (0..$#sorted) {
    for my $j ($i+1..$#sorted) {
        next OUTER if is_contained($sorted[$i], $sorted[$j]);
    }
    push @primes, $sorted[$i];
} 
print "@primes\n";

sub is_contained 
{
    my ($small, $large) = @_;
    my @small = split '/', $small;
    my @large = split '/', $large;

    # There can be no duplicates so equal-length paths are distinct
    return 0 if @small == @large;

    # Indices of elements of @small in @large cannot decrease
    my ($match, $index) = (0, 0);
    for my $sm (@small) {
        for my $i (0..$#large) {
            $sm == $large[$i] || next;
            return 0 if $i < $index;  # out of order
            $index = $i;
            $match = 1;
            last;
        }
        return 0 if not $match;       # $sm from @small not in @large
        $match = 0;
    }
    return 1;
}

打印行:902/904 903/904/902/901 903/904/902/908/900。

关于我们如何检查 @smaller 是否与 @larger 中的子序列匹配的注释。

一旦在 @larger 中找到一个 @smaller 元素，它在 @larger 中的索引不能低于之前找到的那个。元素必须位于前一个元素之后，而不是之前。请参阅下面的不同程序。

因此对于 2/7/5 和 1/2/5/7/8，第一个 2 位于索引 1，然后 7 在索引 3 处，然后是 5 但在索引 2 处。子序列 2-5-7 与 2-7-5 不匹配。我将 902/904 添加到数据中以对此进行测试。

---

这是检查路径是否包含在另一个路径中的替代过程。

一旦它在 @larger 中找到 @smaller 的元素，它就会在 中搜索下一个从下一个索引开始 @更大。这样它会跳过路径的搜索部分，但它也无法及早检测到乱序元素。

以2/7/5和1/2/5/7/8为例，在索引处找到7后3 它从索引 4 开始，并通过在目标路径的其余部分中未找到 5 来检测失败。

sub is_contained_2 
{
    my @large = split '/', $_[0];
    my @small = split '/', $_[1];

    # Is @small found in @large as an exact sub-sequence?
    my ($match, $j) = (0, 0); 
    for my $sm (@small) {
        for my $i ($j..$#large) {
            $sm == $large[$i] || next;
            $j = $i+1, $match = 1;
            last;
        }
        return 0 if not $match;
        $match = 0;
    }
    return 1;
}

对于此数据集，这慢(慢了 10-15%)，请参阅下面的评论基准。

---

我在这里对两个基于数组的版本和 ikegami 进行了基准测试的正则表达式+特里。到目前为止，我仅使用了问题中的特定数据集，并添加了 902/904。

use warnings;
use strict;
use Benchmark qw(cmpthese);
my $secs_to_run = shift || 10; 
my @arr = ('902/904', '903/900', '903/902/900', '903/904/902/901', 
           '903/904', '/902/908/900', '903');

# sorted array checked shorter-to-longer, manual iterations
sub contained {  
    my ($rarr) = @_; my @arr = @$arr;
    # program copied from this post
    return \@primes;
}
sub is_contained { ... }   # copied

# Same program, but using is_contained_2()
sub contained_2 {  ... }
sub is_contained_2 { ... }

# Regex-trie, copied from ikegami's post
sub add { my $p = \shift; $p = \( $$p->{$_} ) for @_, ''; }
sub as_pat { my $trie = shift; ... }  # copied

sub regex_trie { 
    my ($rpaths) = @_; my @paths = @$rpaths;
    # program copied from ikegami's post
    return \@filtered_paths;
}

cmpthese(-$secs_to_run, {
    containted  => sub { my $rprimes   = contained(\@arr)  },
    cont_next   => sub { my $rprimes   = contained_2(\@arr)  },
    regex_trie  => sub { my $rfiltered = regex_trie(\@arr)  },
});

使用 bench_cont.pl 300，在装有 v5.16 的较新工作站笔记本电脑 (2.5GHz) 上

              Rate regex_trie  cont_next containtedregex_trie 15264/s         --       -15%       -27%cont_next  17946/s        18%         --       -14%containted 20939/s        37%        17%         --

on an older server (2.8GHz) with v5.16

              Rate regex_trie  cont_next containtedregex_trie 11750/s         --       -13%       -27%cont_next  13537/s        15%         --       -16%containted 16042/s        37%        19%         --

on an older server (3.5GHz) with v5.10

              Rate  cont_next regex_trie containtedcont_next  12266/s         --       -17%       -17%regex_trie 14832/s        21%         --        -0%containted 14845/s        21%         0%         --

This surprised me, as I expected the regex-based solution to be fastest.

I expect the trend to reverse for data composed of longer paths, having more distinct (not contained) paths, with containment found later in the path, and with a few out-of-order dismissals.

I'll add tests once I get to generate such data, or once it is provided.

---

To track some of the processing change the body to

use feature 'say';

OUTER:
for my $i (0..$#sorted) {
    say "Check $sorted[$i]";
    for my $j ($i+1..$#sorted) {
        my $is_inside = is_contained($sorted[$i], $sorted[$j]);
        say "\t$is_inside: $sorted_arr[$i] inside $sorted_arr[$j]";
        next OUTER if $is_inside;
    }
    push @primes, $sorted[$i];
}
say "\nNot contained: @primes";

这打印

Check 903        0: 903 vs. 902/904        1: 903 vs. 903/900Check 902/904        0: 902/904 vs. 903/900        0: 902/904 vs. 903/902/900        0: 902/904 vs. 903/904/902/901        0: 902/904 vs. 903/904/902/908/900Check 903/900        1: 903/900 vs. 903/902/900Check 903/902/900        0: 903/902/900 vs. 903/904/902/901        1: 903/902/900 vs. 903/904/902/908/900Check 903/904/902/901        0: 903/904/902/901 vs. 903/904/902/908/900Check 903/904/902/908/900Not contained: 902/904 903/904/902/901 903/904/902/908/900