Find any permutation of a set using Perl's RegEx - regex

Question

I need to find a way of checking for the existence of sets of the type {1,2,3,4,5,6,8,9,10}, that have a preset number of elements. Also, notice the missing 7. Obviously the numbers could be in any order and should appear only once, since according to definition, {1,2,3} = {3,2,1} = {1,2,3,3} = ... and so forth.
How could I do this with Perl (or is it even possible)? One thing I tried was
{([1-6],|[8-9],|10,){8}([1-6]|[8-9]|10)} here, but this doesn't take care of the multiple instances of the same number within the brackets.

Answer 1

Regexes are almost certainly the wrong tool here. You want something that deals with permutations of an input list.
This blog post gives a useful overview of Perl modules that deal with permutations and combinations. Sounds to me like Algorithm::Combinatorics would be a good place to start. Something like this, perhaps:
use Algorithm::Combinatorics;
my #input = qw[1 2 3 4 5 6 8 9 10];
my #perms = permutations(\#input);
You then need some way to compare the valid permutations with the sets you want to test. I'd consider constructing a string representation of the sets (by joining them with a known delimiter) and doing a simple string comparison.
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;
}
}
The success of the match is now in $match.

Answer 2

This regex does that.
Here 10 slots are allocated, but you can add as many as you want ( a hundred ? ).
It doesn't mean you have to match 10 unique numbers in a set,
You can match anything less than or equal to 10 (example {5}),
or even a range like {3,7}
The slots will be filled sequentially starting from 1.
So, you just have to sit in a loop from 1 - N, seeing if it is defined.
If you're looking for speed, this is the demon you want !
/\{(?>(?>(?(1)(?!))((?&GetNum))|(?(2)(?!))((?&GetNum))|(?(3)(?!))((?&GetNum))|(?(4)(?!))((?&GetNum))|(?(5)(?!))((?&GetNum))|(?(6)(?!))((?&GetNum))|(?(7)(?!))((?&GetNum))|(?(8)(?!))((?&GetNum))|(?(9)(?!))((?&GetNum))|(?(10)(?!))((?&GetNum)))(?:,(?!\})|(?=\}))){3,7}\}(?(DEFINE)(?<GetNum>(?!(?:\g{1}|\g{2}|\g{3}|\g{4}|\g{5}|\g{6}|\g{7}|\g{8}|\g{9}|\g{10})\b)\d+))/
https://regex101.com/r/pPwPTe/1
Readable regex
# Unique numbers in set, 10 slots
\{
(?> # Atomic, no backtracking allowed
(?> # ditto
(?(1) (?!) ) ( (?&GetNum) ) # (1), Slot 1
| (?(2) (?!) ) ( (?&GetNum) ) # (2), Slot 2
| (?(3) (?!) ) ( (?&GetNum) ) # (3), Slot 3
| (?(4) (?!) ) ( (?&GetNum) ) # (4), Slot 4
| (?(5) (?!) ) ( (?&GetNum) ) # (5), Slot 5
| (?(6) (?!) ) ( (?&GetNum) ) # (6), Slot 6
| (?(7) (?!) ) ( (?&GetNum) ) # (7), Slot 7
| (?(8) (?!) ) ( (?&GetNum) ) # (8), Slot 8
| (?(9) (?!) ) ( (?&GetNum) ) # (9), Slot 9
| (?(10) (?!) ) ( (?&GetNum) ) # (10), Slot 10
)
(?: , (?! \} ) | (?= \} ) )
){3,7} # Set range, example: 3 to 7 unique numbers in set
\}
(?(DEFINE)
(?<GetNum> # (4) Get a new number, must not be seen before
(?! (?: \g{1}|\g{2}|\g{3}|\g{4}|\g{5}|\g{6}|\g{7}|\g{8}|\g{9}|\g{10} ) \b )
\d+
)
)

Answer 3

Given front matter and test cases of
#! /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}",
);
you have at least three approaches to implementing what you want.
Brute force
When in doubt, try a bigger hammer. Generate all permutations and bake those into your pattern directly. Note that this has a factorial cost, so it quickly becomes intractable as the number of elements in your set grows.
# 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";
}
Generating all permutations on my laptop takes about 3 minutes. Precomputing the pattern may or may not make sense depending on your application.
Piggyback on the regex engine’s backtracking
One way to do it is to take advantage of the Perl regex engine’s backtracking and running (?{ code }) at various points within your pattern.
Define members of your set as below. Note that these must be global variables because of limitations of the regex engine, so use our and not my.
# must use package variables inside (?{ })
our #members = (1 .. 6, 8 .. 10);
our %remaining;
A pattern that matches permutations becomes
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 inside (?{ code }) sections runs at corresponding points of the pattern match. For example, the first one initializes the hash %remaining to contain all members of the set as keys.
The second and third (?{ code }) sections are within (?(condition)yes-pattern|no-pattern) sections and (*FAIL) backtracking control verbs. For any member before the last in the set (which we know because it is terminated by a comma), the member just matched, available in the $^N special variable, must be still available in %remaining. For the last member (terminated by right curly brace), the member just matched must be available and we must have covered all elements of the set to succeed. If these constraints are met, we match against an empty yes-pattern and continue successfully, but if one of these conditions fails, we meet (*FAIL) in the no-pattern. This causes the current attempted match to fail and the regex engine backtracks to attempt the next possibility.
Writing delete local localizes deletion of the particular key from %remaining. This delegates the error-prone bookkeeping to the regex engine that correctly restores localized values when it backtracks past a non-viable match.
Note that this implementation requires a set of at least two members.
Use it as in
for (#tests) {
my $result = /^ $permutation $/x ? "ACCEPT" : "REJECT";
print "$_ - $result\n";
}
Hybrid approach
Finally, combine the approaches by searching for everything that looks like a set and reject invalid permutations.
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";
}
Test output
For all three, the output is
{} - 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