Regex matching characters of one string in another in any order - regex

Question

Consider the following string wizard. I want to find if it is in another string in any order and in any case.
I tried the following
while(<>){if($_=~/(?:([wizard])(?!.*\1)){6}/i){print"0"}else{print"1"}}
For the inputs
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora
It printed 111111 but it must have been 111011.
So, I tried this instead (for the same inputs)
while(<>){if($_=~/(?=[wizard]{6})(?!.*(.).*\1).*/i){print"0"}else{print"1"}}
It again printed 111111.
In input number 4, we can make WaDriaz but only one a is needed. Anyway, we can spell wizard by rearranging and in any case. Why is it not working?
What is wrong with my code?

Answer 1

The following should be quite fast (especially if you inline the subs):
use feature qw( fc say );
sub make_key {
my %counts;
++$counts{$_} for split //, fc($_[0]) =~ s/\PL//rg;
return \%counts;
}
sub search {
my ($substr, $str) = #_;
$str = make_key($str);
no warnings qw( uninitialized );
return !( grep { $str->{$_} < $substr->{$_} } keys(%$substr) );
}
my $substr = make_key("wizard");
while (<>) {
chomp;
say search($substr, $_) ? 0 : 1;
}
Unlike virtually all of the previous solutions, this one doesn't consider latte to be in late.
The following is a regex based solution (with some prep). This should also be quite fast (especially if you inline the subs).
use feature qw( fc say );
sub make_re {
my $pat = join ".*?", map quotemeta, sort split //, fc($_[0]) =~ s/\PL//rg;
return qr/$pat/s;
}
sub search {
my ($substr, $str) = #_;
return ( join "", sort split //, $str ) =~ $substr;
}
my $substr = make_re("wizard"); # qr/a.*?d.*?i.*?r.*?w.*?z/is
while (<>) {
chomp;
say search($substr, $_) ? 0 : 1;
}
Finally, a purely regexp-based solution.
use feature qw( fc say );
sub make_re {
my %counts;
++$counts{$_} for split //, fc($_[0]) =~ s/\PL//rg;
my $pat =
join "",
map { "(?=".( ( ".*?" . quotemeta($_) ) x $counts{$_} ).")" }
#sort
keys(%counts);
return qr/^$pat/s;
}
my $re = make_re("wizard"); # qr/^(?=.*?a)(?=.*?d)(?=.*?i)(?=.*?r)(?=.*?w)(?=.*?z)/is
while (<>) {
say /$re/ ? 0 : 1;
}
Unlike virtually all of the previous solutions, none of mine consider latte to be in late.

Answer 2

Here is a pure regex: do a positive lookahead for each character
use warnings;
use strict;
use feature 'say';
use List::Util qw(uniq); # before v. 1.45 in List::MoreUtils
my $string = shift // q(wizard);
my $patt = join '', map { qq{(?=.*\Q$_\E)} } uniq split //, $string;
# say $patt;
#--> (?=.*w)(?=.*i)(?=.*z)(?=.*a)(?=.*r)(?=.*d) (for wizard)
while (<DATA>) {
say "Found '$string' in: $_" if /^$patt/is;
}
__DATA__
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora
Being all in one regex, with an anchored lookahead and no overhead, this should be very fast.
The \Q...\E are there in case the search string contains regex-sensitive characters.
This code considers words with repeated characters (latte, rare) to "fit" a word without that (later). It is clarified in comments that this is indeed the wanted behavior: repeated characters need only be found once in the target (letter matches later etc).

Answer 3

I find canonicalization of the inputs and the pattern to be a more generalizable and understandable approach:
#!/usr/bin/env perl
use strict;
use warnings;
sub canonchars {
my %c;
$c{$_} = undef for map lc, grep /\S/, split //, $_[0];
sort keys %c;
}
sub pattern {
map "$_.*", canonchars($_[0]);
}
my %canonical;
while (my $line = <DATA>) {
last unless $line =~ /\S/;
push $canonical{join '', canonchars($line)}->#*, $line;
}
my $pat = qr/#{[join '', pattern('wizard')]}/;
for my $k (keys %canonical) {
if ($k =~ $pat) {
print for $canonical{$k}->#*;
}
}
__DATA__
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora
Output:
C:\Temp> perl t.pl
Wayne Drimaz
There is a lot of logic you are trying to fit into a regular expression pattern, and every edge case you find and fix will make it more complicated and more fragile.

Answer 4

It's just a simple matter of using a positive lookahead for every character.
my #stars = (
'Garry Kasparov',
'Bobby Fischer',
'Vladimir Kramnik',
'Wayne Drimaz',
'Lionel Messi',
'La Signora'
);
say /^(?=.*w)(?=.*i)(?=.*z)(?=.*a)(?=.*r)(?=.*d)/i ? 0 : 1 for #stars;
This outputs 111011.

Answer 5

No need for regular expressions... they just complicate things, especially if you're not looking for a string you know ahead of time. Just look for each character in turn after normalizing their cases.
#!/usr/bin/env perl
use strict;
use warnings;
sub contains_chars {
my ($needle, $haystack) = #_;
$haystack = lc $haystack;
my %positions;
for my $char (split //, lc $needle) {
my $p = index $haystack, $char, $positions{$char}//0;
return 1 if $p < 0;
$positions{$char} = $p + 1;
}
return 0;
}
while (<DATA>) {
print contains_chars("wIzArD", $_);
}
print "\n";
__DATA__
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora

Answer 6

This a black art way that out of order matching can occur.
Each character in the source string is visited only once.
No need to recurse the string from the beginning for each letter.
use strict;
use warnings;
while (my $line = <DATA>) {
if ( $line =~ /
(?:
.*?
(?:
(?(1)(?!))(w)
| (?(2)(?!))(i)
| (?(3)(?!))(z)
| (?(4)(?!))(a)
| (?(5)(?!))(r)
| (?(6)(?!))(d)
)
){6}/ix ) { print $line, "\n" }
}
__DATA__
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora
Wayne Drimaz
Captures can exist in two states, defined or undefined.
The essence of this black art is to use the state of captures as flags
to insure all the items are matched in the out-of-order state.
The above can also be written this way with the same result.
use strict;
use warnings;
while (my $line = <DATA>) {
if ( $line =~ /
(?im)
^
(?>
.*?
(?:
w ( ) # (1)
| i ( ) # (2)
| z ( ) # (3)
| a ( ) # (4)
| r ( ) # (5)
| d ( ) # (6)
)
)+
(?= \1 \2 \3 \4 \5 \6 )
/x ) { print $line, "\n" }
}
__DATA__
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Lionel Messi
La Signora

Answer 7

Just adding a simple variant of /w/ && /i/ && /z/ ... solution I mentioned in comments. If you want this solution to match a lot of different strings, instead of lining the regexes together with &&, you can simply loop over the characters. A useful tool is to use the &&= operator to mimic the behaviour of a long string of conditions. This will also allow us to short-circuit the matching if we find a mismatch, giving us a speed benefit.
For example:
/a/ && /b/ && /c/
Equivalent to
my $match = 1;
for my $w (qw(a b c)) {
$match &&= (/$w/); # $match = ($match && /$w/)
}
To remember the count of letters, i.e. whether latte should be considered to be a substring of late, you can simply use the substitution operator s/// instead of match operator m//. I added the multi-letter criteria, and added two test cases to demonstrate.
I like this solution because of the simplicity, but thereby not said it is the best one.
use strict;
use warnings;
my $word = "wizzard";
while (<DATA>) {
print search($_, $word), " $_";
}
sub search {
my ($str, $substr) = #_;
my $match = 1; # assume true
for my $w (split //, $substr) { # for each char in substr...
$match &&= ($str =~ s/\Q$w//i); # ...remove character
return 0 if not $match; # ...return false if no match found
}
return 1 if $match;
}
__DATA__
wizard
wizzard
Garry Kasparov
Bobby Fischer
Vladimir Kramnik
Wayne Drimaz
Wayne Drimazz
Lionel Messi
La Signora
Output:
0 wizard
1 wizzard
0 Garry Kasparov
0 Bobby Fischer
0 Vladimir Kramnik
0 Wayne Drimaz
1 Wayne Drimazz
0 Lionel Messi
0 La Signora
If you do not care about multi-letter matching, just replace s/// with m//.