Perl Weekly Challenge 99.
My solutions (task 1 and task 2) to the The Weekly Challenge - 099.
Task 1: Pattern Match
Submitted by: Mohammad S Anwar
You are given a string $S and a pattern $P.
Write a script to check if given pattern validate the entire string. Print 1 if pass otherwise 0.
The patterns can also have the following characters:
? - Match any single character.
* - Match any sequence of characters.
Example 1:
Input: $S = "abcde" $P = "a*e"
Output: 1
Example 2:
Input: $S = "abcde" $P = "a*d"
Output: 0
Example 3:
Input: $S = "abcde" $P = "?b*d"
Output: 0
Example 4:
Input: $S = "abcde" $P = "a*c?e"
Output: 1
I solve the problem by replacing the pattern by a perl’s regular expression: I
add a start of string ^ and end of string $ markers, and I
replaced ? and * by . and .* . Then I ask perl to match the
resulting regular expression. This may be
done in a oneliner:
perl -E '($S, $P0)=@ARGV; $P=$P0; $P=~s/\*/.*/g; $P=~s/\?/./g;' \
-E 'say "Input: \$S=\"$S\" \$P=\"$P0\"\nOutput: ", $S=~/^$P$/?1:0' "abcde" "a*e"
perl -E '($S, $P0)=@ARGV; $P=$P0; $P=~s/\*/.*/g;' \
-E 'say "Input: \$S=\"$S\" \$P=\"$P0\"\nOutput: ", $S=~/^$P$/?1:0' "abcde" "a*d"
perl -E '($S, $P0)=@ARGV; $P=$P0; $P=~s/\*/.*/g;' \
-E 'say "Input: \$S=\"$S\" \$P=\"$P0\"\nOutput: ", $S=~/^$P$/?1:0' "abcde" "?b*d"
perl -E '($S, $P0)=@ARGV; $P=$P0; $P=~s/\*/.*/g;' \
-E 'say "Input: \$S=\"$S\" \$P=\"$P0\"\nOutput: ", $S=~/^$P$/?1:0' "abcde" "a*c?e"
Results:
Input: $S="abcde" $P="a*e"
Output: 1
Input: $S="abcde" $P="a*d"
Output: 0
Input: $S="abcde" $P="?b*d"
Output: 0
Input: $S="abcde" $P="a*c?e"
Output: 1
Notice that the code would fail if $P contains magical regexp
characters. Thus in the full solution, I escape out any suspicious
character and allow quoted asterisks and question marks.
# Perl weekly challenge 099
# Task 1: Pattern match
#
# See https://wlmb.github.io/2021/02/08/PWC099/#task-1-pattern-match
use warnings;
use strict;
use v5.12;
my ($S, $P0)=@ARGV;
my $P=quotemeta $P0; # quote anything suspicious
$P=~s/^\\\*/.*/; # Replace originally unquoted asterisks
$P=~s/([^\\])\\\*/$1.*/g;
$P=~s/\\\\\*/\*/g; #Replace originally quoted asterisks
$P=~s/^\\\?/./; # Replace originally unquoted question marks
$P=~s/([^\\])\\\?/$1./g;
$P=~s/\\\\\?/\?/g; #Replace originally quoted question marks
say "Input: \$S=\"$S\" \$P=\"$P0\"\nOutput: ", $S=~/^$P$/?1:0;
Examples 1-4:
./ch-1.pl "abcde" "a*e"
./ch-1.pl "abcde" "a*d"
./ch-1.pl "abcde" "?b*d"
./ch-1.pl "abcde" "a*c?e"
Results:
Input: $S="abcde" $P="a*e"
Output: 1
Input: $S="abcde" $P="a*d"
Output: 0
Input: $S="abcde" $P="?b*d"
Output: 0
Input: $S="abcde" $P="a*c?e"
Output: 1
Examples with escaped asterisks and question marks;
./ch-1.pl "abc*def" "a*\**f"
./ch-1.pl "abcdef" "a*\**f"
./ch-1.pl "ab?de" "a?\??e"
./ch-1.pl "abcde" "a?\??d"
Results:
Input: $S="abc*def" $P="a*\**f"
Output: 1
Input: $S="abcdef" $P="a*\**f"
Output: 0
Input: $S="ab?de" $P="a?\??e"
Output: 1
Input: $S="abcde" $P="a?\??d"
Output: 0
Examples with unintended regexp char. Not being a true regexp, the dot should not have its regexp meaning, it should only match itself.
./ch-1.pl "a.c" "a.c"
./ch-1.pl "abc" "a.c"
Results:
Input: $S="a.c" $P="a.c"
Output: 1
Input: $S="abc" $P="a.c"
Output: 0
Task 2: Unique Subsequence
Submitted by: Mohammad S Anwar
You are given two strings $S and $T.
Write a script to find out count of different unique subsequences matching $T without changing the position of characters.
Example 1:
Input: $S = "littleit', $T = 'lit'
Output: 5
1: [lit] tleit
2: [li] t [t] leit
3: [li] ttlei [t]
4: litt [l] e [it]
5: [l] ittle [it]
Example 2:
Input: $S = "london', $T = 'lon'
Output: 3
1: [lon] don
2: [lo] ndo [n]
3: [l] ond [on]
I present a recursive solution: If the first character matches, then try to match rest of pattern to rest of string. In any case, also try to match the full pattern to rest of string. For display, matched characters are enclosed in square brackets, and square brackets in the input are escaped.
# Perl weekly challenge 099
# Task 2: unique subsequence
#
# See https://wlmb.github.io/2021/02/08/PWC099/#task-2-unique-subsequence
use warnings;
use strict;
use v5.12;
use Memoize;
memoize qw(sequences);
my ($S, $T)=@ARGV;
my @sequences=sequences($S, $T);
say "Input: \$S=\"$S\", \$T=\"$T\"";
say "Output: ", scalar @sequences;
say "$_: $sequences[$_-1]" for (1..@sequences);
sub sequences { #Recursively find all matches of $S to $T
my ($S, $T)=@_;
return ("$S") if $T=~/^$/; #nothing more to match
return () if $S=~/^$/; #end of string without match
my ($firstS, $firstT)=map {escape(substr $_,0,1)} $S, $T;
my ($restS, $restT)=map {substr $_,1} $S, $T;
my @sequences=();
@sequences=(map {"[$firstS]$_"} sequences($restS, $restT)) if $firstS eq $firstT;
@sequences=(@sequences, map {"$firstS$_"} sequences($restS, $T));
return @sequences;
}
sub escape { #Escape brackets
my $string=shift;
$string=~s/([][])/\\$1/g;
return $string;
}
Examples 1 and 2:
./ch-2.pl littleit lit
./ch-2.pl london lon
Results:
Input: $S="littleit", $T="lit"
Output: 5
1: [l][i][t]tleit
2: [l][i]t[t]leit
3: [l][i]ttlei[t]
4: [l]ittle[i][t]
5: litt[l]e[i][t]
Input: $S="london", $T="lon"
Output: 3
1: [l][o][n]don
2: [l][o]ndo[n]
3: [l]ond[o][n]
Example with brackets:
./ch-2.pl [abc] []
Results:
Input: $S="[abc]", $T="[]"
Output: 1
1: [\[]abc[\]]
Example with no matches:
./ch-2.pl abc def
Results:
Input: $S="abc", $T="def"
Output: 0