我有一系列的字符串，这些字符串可能被前向斜线隔开，例如754或754/128。这些字符串可能具有不确定的长度，换句话说：诸如以下内容是可能的：1234/34/21/120/3。在数组中，我只想保留包含其他模式的更专业的模式。例如，在上面的第一个示例中，754/128包含754，因此可以从数组中删除754。
这个包含的概念就像人们期望的那样广泛，甚至更广泛：它类似于您查看有向图的方式，在该图案中，图案中的每个斜线都指向前迈出一步。只要包含的模式在包含的模式中以一种或另一种方式就可以是任意长度。这意味着可以以任何（按时间顺序正确）形式出现小路径。例如，即使模式是"拆分打开"，903/900也包含在903/902/900中。可视化这一点的一种方法是：在小路径中，我们从点A到点B。在较大的路径中，我们也从Pont A到B，但我们在C上停下来。较大的路径访问更多比小路径的地方而没有错过任何东西。结果，只要尊重路径的顺序，就可以以任何分裂形式发生较小的路径。例如：
2/5 - 1/2/3/4/5
# included
5/2 - 1/2/3/4/5
# not included
我的意思是，"包含"项目的位置应在大路径中相同。例如：1/5/3/4/2中的1/3/2'匹配'，因为该顺序在小路径和大路径中相同：1在3之前处于位置，而CC_12又在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
我正在寻找有效删除给定数组中其他数组中包含在同一数组中的其他数组中的路径的方法。
我走了这么远，但是我不确定如何有效地检查两个项目之间的关系。
#!/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中是否存在CC_24的一项，如果不继续，但是如果是这样，请检查第二个项目是否也存在，如果是这样，请检查其子弦位置。这必须大于第一个项目的基因位置。继续为每个项目（以及@second_items和$first的相反方式），直到将所有字符串匹配为止。（如果对速度有所帮助，则可以将初始数组与以前的数组作为键交换为哈希。）
我希望有一些通用算法可以解决此问题，并且可能可以利用库。但是，这是一个手工卷的。
首先，我们按路径中的项数对数组进行排序。然后，我们将每个元素与所有更长的元素进行比较。这样，每条路径都会尽早被排除在外。
比较是通过在/上拆分获得的数组之间的比较。它检查了较大数组的所有元素是否为确切的子序列，因此较大的元素仅通过删除元素（没有重排）就能产生较小的元素。
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 "@primesn";
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 上找到，然后在index 3 处找到7，然后在 5中，但在index 2 。子序列2-5-7与2-7-5不匹配。我将902/904添加到数据中以对此进行测试。
这是检查路径是否包含在另一个路径中的替代过程。
一旦在@larger中找到@smaller的元素后，它就会从@larger中的下一个索引开始搜索下一个。这样，它跳过了路径的搜索部分，但也无法尽早检测到序列元素。
以 2/7/5和 1/2/5/7/8的示例，在索引 3 找到 7之后，它是从index 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％），请参见下面的评论。
i在这里和Ikegami的Regex Trie基于两个基于数组的版本。到目前为止
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，在较新的工作站通信（2.5GHz）上，带有v5.16
评价Regex_trie cont_nextREGEX_TRIE 15264/s- -15％-27％cont_next 17946/s 18％ - -14％引人入胜的20939/S 37％17％ -
在带有v5.16的旧服务器（2.8GHz）上
评价Regex_trie cont_nextREGEX_TRIE 11750/S- -13％-27％cont_next 13537/s 15％ - -16％引人入胜的16042/s 37％19％ -
在带有v5.10
的旧服务器（3.5GHz）上评价cont_next Regex_trie不知不觉cont_next 12266/s- -17％-17％REGEX_TRIE 14832/S 21％ - -0％引人入胜的14845/s 21％0％ -
这使我感到惊讶，因为我期望基于正则的解决方案最快。
我希望趋势会逆转由较长路径组成的数据，具有更明显的路径（未包含）路径，后来在路径中发现了围栏，并且有一些排序的解雇。
一旦获得此类数据，我将添加测试。
。跟踪某些处理将身体更改为
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";
此打印
检查903 0：903与902/904 1：903与903/900检查902/904 0：902/904与903/900 0：902/904与903/902/900 0：902/904与903/904/902/901 0：902/904与903/904/902/908/900检查903/900 1：903/900与903/902/900检查903/902/900 0：903/902/900与903/904/902/901 1：903/902/900与903/904/902/908/900检查903/904/902/901 0：903/904/902/901与903/904/902/908/900检查903/904/902/908/900未包含：902/904 903/904/902/901 903/904/902/908/900
以优化到目前为止的内容，我建议您 pre-split 阵列的所有元素（and）然后稍后重新合并）：
@arr = map [split "/", $_], @arr;
完成：
sub contains(@@) {
my ($larger_ref, $smaller_ref) = @_;
return '' if @$larger_ref <= @$smaller_ref;
my ($i, $j) = 0;
while ($i < @$larger_ref && $j <= @$smaller_ref) {
++$j if $larger_ref->[$i] == $smaller_ref->[$j];
++$i;
}
return $j == @$smaller_ref;
}
I: for (my $i = 0; $i < @arr; ++$i) {
J: for (my $j = 0; $j < @arr; ++$j) {
next J if $j == $i;
next I if contains @{$arr[$j]}, @{$arr[i]};
}
push @res, join '/', @{$arr[$i]};
}
您可以在contains中进行一些潜在的进一步优化（例如，如果/当@$larger_ref - $i < @$smaller_ref - $j时，可以提早中止可能是有意义的，但是您需要测试：它们可能会变成pessimization。
如果 a/b/c是路径，则要删除以下路径为true的路径：
"/$path" =~ m{ ^ (?:/a)?+ (?:/b)?+ (?:/c)?+ z }x && $path ne 'a/b/c'
也可以写为
"/$path" =~ m{ ^ (?:/a)?+ (?:/b)?+ (?:/c)?+ z (?<! ^ /a/b/c ) }x
如果a/b/c，a/i/j，a/x/y和d/e/f都是路径，则要删除以下路径为true的路径：
"/$path" =~ m{
^ (?:/a)?+ (?:/b)?+ (?:/c)?+ z (?<! ^ /a/b/c )
| ^ (?:/a)?+ (?:/i)?+ (?:/j)?+ z (?<! ^ /a/i/j )
| ^ (?:/a)?+ (?:/x)?+ (?:/y)?+ z (?<! ^ /a/x/y )
| ^ (?:/d)?+ (?:/e)?+ (?:/f)?+ z (?<! ^ /d/e/f )
}x
我们使用所有格修饰符（+）删除了很多回溯，但是由于常见的前缀，仍然有可能进行回溯。因此，让我们删除它们！
"/$path" =~ m{
^
(?: (?:/a)?+ (?: (?:/b)?+ (?:/c)?+ z (?<! ^ /a/b/c )
| (?:/i)?+ (?:/j)?+ z (?<! ^ /a/i/j )
| (?:/x)?+ (?:/y)?+ z (?<! ^ /a/x/y )
)
| (?:/d)?+ (?:/e)?+ (?:/f)?+ z (?<! ^ /d/e/f )
)
}x
现在我们有一个有效的解决方案！
以下操作使用Trie来删除常见前缀。
use strict;
use warnings;
use feature qw( say );
sub add {
my $p = shift;
$p = ( $$p->{$_} ) for @_, '';
}
sub as_pat {
my $trie = shift;
my @sub_pats =
map { $_ eq '' ? '' : $_ . as_pat($trie->{$_}) }
keys(%$trie);
if (@sub_pats == 1) {
return $sub_pats[0];
} else {
return '(?:'.join('|', @sub_pats).')';
}
}
my @paths = ( "903/900", "903/902/900", "903/904/902/901", "903/904/902/908/900", "903" );
my $trie;
add($trie, map({ "(?:/Q$_E)?+" } split qr{/}), "\z(?<!^/Q$_E)" )
for @paths;
my $pat = as_pat($trie);
my $re = qr{^(?:$pat)};
my @filtered_paths = grep { "/$_" !~ /$re/ } @paths;
say for @filtered_paths;
说n是路径的数量，o（m）界限路径的长度。像较早的答案一样，此答案在O（N 2 * m 2 ）时间中完成，因此它不能更好地扩展。但是，我相信您会发现我的速度会更快。路径，较早的答案在o（n 2 * m 2 ）中完成。
以下解决方案是O（n * 2 m ）。这意味着它可以更有效地处理大量路径，只要路径相当短（因为它有效地变成o（n 2 ）vs o（n））。它确实需要的内存比早期答案中的解决方案要多得多。
use strict;
use warnings;
use feature qw( say );
sub fetch {
my $trie = shift;
for (@_, '') {
return () if !$trie;
$trie = $trie->{$_}
}
return $trie;
}
sub add {
local *_helper = sub {
my $trie_ptr = shift;
my $exact = shift;
if (@_) {
my $lead = shift(@_);
_helper($$trie_ptr->{$lead}, $exact, @_);
_helper($$trie_ptr, 0, @_);
} else {
if ($exact) {
$$trie_ptr->{''} ||= 1;
} else {
$$trie_ptr->{''} = 2;
}
}
};
my $trie_ptr = shift;
return _helper($$trie_ptr, 1, @_);
}
my @paths = ( "903/900", "903/902/900", "903/904/902/901", "903/904/902/908/900", "903" );
my @split_paths = map [ split qr{/} ], @paths;
my $trie;
add($trie, @$_)
for @split_paths;
use Data::Dumper qw( Dumper );
local $Data::Dumper::Sortkeys = 1;
print(Dumper($trie));
my @filtered_paths =
map join('/', @$_),
grep { fetch($trie, @$_) == 1 }
@split_paths;
say for @filtered_paths;