如何在 Perl 中查找子列表模式的索引

Question

我有一个较长的列表，其元素是多字符符号，例如：

@c = qw(iim v7 v7 iM iv7 iM im iv7 iv7 bviiM im biio iim bviim biiM biim bviM bviM ivm iih v7 v7 v7 iiim iiih vi7 iim v7 v7 iM iv7 iM im iv7 bviiM im biio iim bviim bviim iio iim v7 v7 v7 vm i7 ivM iiih vi7);

我想在此列表中找到与 S1+ S2+ S3+ 类型的子列表匹配的索引，其中“+”表示匹配一次或多次。因此，例如，子列表模式(im iv7 bviiM) 将匹配(im iv7 iv7 bviiM) 和(im iv7 bviiM)，如上面以粗体突出显示的那样。该代码将为第一个匹配提供索引 6、7、8、9，为第二个匹配提供 32、33、34。

从表面上看，这似乎不应该是困难的，我已经尝试用各种方法来实现它，包括正则表达式，但到目前为止它已经打败了我。如果有一种简单的方法可以做到这一点，我将不胜感激。

Answer 1

一个有趣的问题，因为重复的元素还需要与给定子序列中的项目匹配，同时需要保持顺序。

use warnings;
use strict;
use feature 'say';
use Data::Dump qw(dd);

my @words = qw(iim v7 v7 iM iv7 iM im iv7 iv7 bviiM im biio iim bviim biiM
    biim bviM bviM ivm iih v7 v7 v7 iiim iiih vi7 iim v7 v7 iM iv7 iM im 
    iv7 bviiM im biio iim bviim bviim iiio iim v7 v7 v7 vm i7 ivM iiih vi7);

my @subseq = qw(im iv7 bviiM);

my (@all_seqs, @mi);
my $s = 0;

for my $i (0 .. $#words) { 
    if ($words[$i] eq $subseq[$s]) {  # first in @subseq or repeated from @words
        push @mi, $i;
    }   
    elsif (@mi and $s == @subseq-1) { # done, exhausted @subseq
        push @all_seqs, [ @mi ];  
        $s = 0;
        @mi = (); 
    }   
    elsif (@mi and $words[$i] eq $subseq[++$s]) { # next in @subseq
        push @mi, $i;
    }
    elsif (@mi) { # failed to match all from @subseq
        $s = 0;  
        @mi = ();
    }
}
dd \@all_seqs;

@mi 包含在第一个测试之后的所有测试中，因此它们仅在已匹配某些内容时才执行。

打印

[[6 .. 9], [32, 33, 34]]

取消注释打印行以跟踪其操作。这已经在上面的基本运行之外进行了测试，但还不够好。

---

或者，将所有单词连接成一个字符串并匹配子序列，连接成一个模式，通过正则表达式；那么很容易处理可能的重复。 为了在匹配中也从原始数组中提取索引，我在每个单词前面加上__INDEX__。

# Same @words and @subseq from above

my $w = join '', map { '__'.$_.'__' . $words[$_] } 0.. $#words;

my $patt = '(' . 
    join('', map { '(?:' . '__[0-9]+__' . quotemeta($_) . ')+' } @subseq) . ')';

my @seqs = $w =~ /$patt/g;

my @seqs_idx = map { [ /__([0-9]+)__/g ]  } @seqs;

dd \@seqs_idx;

因为__IDX__ 不能在@words 或@subseq 中，所以应该检查它。这会影响效率，因此可能会使用一个更不可能使用索引构建的分隔符标记（如果它包含正则表达式特殊字符，则在基于@subseq 的模式中将其通过quotemeta）。

Answer 2

你的意思是这样的吗？

#! /usr/bin/env perl

use warnings;
use strict;
use utf8;
use feature qw<say>;
use List::Util qw<any>;

my @sub_pat = qw(im iv7 bviiM);
my @c =
    qw(
    iim v7 v7 iM 
    iv7 iM im iv7 
    iv7 bviiM im biio 
    iim bviim biiM biim 
    bviM bviM ivm iih
    v7 v7 v7 iiim 
    iiih vi7 iim v7 
    v7 iM iv7 iM 
    im iv7 bviiM im 
    biio iim bviim bviim 
    iiio iim v7 
    v7 v7 vm i7 
    ivM iiih vi7
    );

my %ans = ();

while (my ($i, $k) = each @c) {
    push @{$ans{$k}}, $i if any {$_ eq $k} @sub_pat;
}

while (my ($k, $v) = each %ans) {
    say "$k @{$v}";
}

exit(0);