Найти любую перестановку набора, используя Perl's RegEx

Regexes - почти наверняка неправильный инструмент здесь. Вы хотите что-то, что связано с перестановками входного списка.

Это сообщение в блоге дает полезный обзор модулей Perl, связанных с перестановками и комбинациями. Звучит для меня как Алгоритм :: Комбинаторика будет хорошим местом для начала. Что-то вроде этого, возможно:

use Algorithm::Combinatorics;

my @input = qw[1 2 3 4 5 6 8 9 10];

my @perms = permutations(\@input);

Затем вам нужно каким-то образом сравнить допустимые перестановки с наборами, которые вы хотите протестировать. Я бы подумал о построении строкового представления множеств (путем объединения их с известным разделителем) и простого сравнения строк.

my @perm_strs = map { join ':' } @perms;

my @test = qw[2 4 3 1 10 5 9 8 6];
my $test_str = join ':', @test;

my $match = 0;
for (@perm_strs) {
  if ($test_str eq $_) {
    $match = 1;
    last;
  }
}

Успех совпадения теперь находится в $match.

Учитывая переднюю материю и тестовые примеры

#! /usr/bin/env perl

use strict;
use warnings;

my @tests = (
  "{}",
  "{1,1}",
  "{1,2,3,4,5,6,8,9,10}",
  "{1,1,2,3,4,5,6,8,9,10}",
  "{1,2,3,4,5,6,7,8,9,10}",
  "{10,9,8,7,6,5,4,3,2,1}",
  "{10,9,8,6,5,4,3,2,1}",
  "{10,9,8,6,5,4,3,2,1",
  "{10,9,8,6,5,4,3,2,1,1}",
  "{2,4,6,8,10,9,5,3,1}",
);

, у вас есть как минимум три подхода к реализации того, что вы хотите.

Грубая сила

Когда в сомневайтесь, попробуйте больший молот. Сгенерируйте все перестановки и испеките их в свой шаблон напрямую. Обратите внимание, что это имеет факториальную стоимость, поэтому она быстро становится трудноразрешимой по мере роста количества элементов в вашем наборе.

# perlfaq4: How do I permute N elements of a list?
sub permute (&@) {
  my $code = shift;
  my @idx = 0..$#_;
  while ( $code->(@_[@idx]) ) {
    my $p = $#idx;
    --$p while $idx[$p-1] > $idx[$p];
    my $q = $p or return;
    push @idx, reverse splice @idx, $p;
    ++$q while $idx[$p-1] > $idx[$q];
    @idx[$p-1,$q]=@idx[$q,$p-1];
  }
}

my $brute_force;
permute { local $" = ",";
          $brute_force .= "|" if $brute_force;
          $brute_force .= "{@_}" }
  @members;

$brute_force = qr/ ^ (?: $brute_force ) $/x;

for (@tests) {
  my $result = /$brute_force/x ? "ACCEPT" : "REJECT";
  print "$_ - $result\n";
}

Создание всех перестановок на моем ноутбуке занимает около 3 минут.

Piggyback при обратном трассировке двигателя regex

. Один из способов сделать это - воспользоваться возвратным движком двигателя regex для Perl и работает (?{ code }) в разных точках вашего шаблона.

Определите членов вашего набора, как показано ниже. Обратите внимание, что это должны быть глобальные переменные из-за ограничений движка regex, поэтому используйте our, а не my.

# must use package variables inside (?{ })
our @members = (1 .. 6, 8 .. 10);
our %remaining;

Образец, соответствующий перестановкам, становится

my $permutation = qr!
  \{  (?{ @remaining{@members} = map +($_ => 1), @members })

  ( ([0-9]+), (?(?{ delete local $remaining{$^N} })|(*FAIL)))+

  ([0-9]+)\} (?(?{ delete local $remaining{$^N} && keys %remaining == 0 })|(*FAIL))
!x;

Код внутри раздела (?{ code }) выполняется в соответствующих точках совпадения шаблонов. Например, первая инициализирует хэш %remaining, чтобы содержать все элементы набора в качестве ключей.

Вторая и третья секции (?{ code }) находятся внутри разделов (?(condition)yes-pattern|no-pattern) и (*FAIL) контрольных глаголов контроля возврата . Для любого члена до последнего в наборе (который мы знаем, потому что он завершен запятой), член, только что сопоставленный, доступный в специальной переменной $^N, должен быть доступен в %remaining. Для последнего участника (заканчивающегося правой фигурной скобкой) член должен быть доступен, и мы должны были охватить все элементы набора, чтобы добиться успеха. Если эти ограничения удовлетворяются, мы сопоставляем с пустым yes-pattern и продолжаем успешно, но если одно из этих условий выходит из строя, мы встречаем (*FAIL) в нет-шаблон . Это приводит к сбою текущего попытки совпадения, и двигатель regex отступает, чтобы попытаться сделать следующую возможность.

Написание delete local локализует удаление конкретного ключа из %remaining. Это делегирует неуправляемую ошибками бухгалтерию к механизму регулярного выражения, который правильно восстанавливает локализованные значения, когда он возвращается назад из-за нежизнеспособного соответствия.

Обратите внимание, что для этой реализации требуется набор из по меньшей мере двух членов.

Используйте его как в

for (@tests) {
  my $result = /^ $permutation $/x ? "ACCEPT" : "REJECT";
  print "$_ - $result\n";
}

Гибридный подход

Наконец, объедините подходы, выполнив поиск всего, что выглядит как набор, и отклоните недопустимые перестановки.

sub _assert_permutation_of {
  my($members,$set) = @_;
  my %seen = map +($_ => 1), @$members;
  while ($set =~ /\b([0-9]+)\b/g) {
    return unless delete $seen{$1};
  }
  keys %seen == 0;
}

my $hybrid = qr!
  (  \{                # opening brace
     (?: [0-9]+ , )+   # comma-terminated integers
         [0-9]+        # final integer
     \}                # closing brace
  )
  (?(?{ _assert_permutation_of \@members, $^N })|(*FAIL))
!x;

for (@tests) {
  my $result = /^ $hybrid $/x ? "ACCEPT" : "REJECT";
  print "$_ - $result\n";
}

Контрольный выход

Для всех трех выход:

{} - REJECT
{1,1} - REJECT
{1,2,3,4,5,6,8,9,10} - ACCEPT
{1,1,2,3,4,5,6,8,9,10} - REJECT
{1,2,3,4,5,6,7,8,9,10} - REJECT
{10,9,8,7,6,5,4,3,2,1} - REJECT
{10,9,8,6,5,4,3,2,1} - ACCEPT
{10,9,8,6,5,4,3,2,1 - REJECT
{10,9,8,6,5,4,3,2,1,1} - REJECT
{2,4,6,8,10,9,5,3,1} - ACCEPT