Merge pull request #3514 from PerlMonk-Athanasius/branch-for-challenge-099

Perl & Raku solutions to Tasks 1 & 2 of the Perl Weekly Challenge #099

4 files changed, 639 insertions, 0 deletions

diff --git a/challenge-099/athanasius/perl/ch-1.pl b/challenge-099/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..5bf169a13e
--- /dev/null
+++ b/challenge-099/athanasius/perl/ch-1.pl
@@ -0,0 +1,132 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl 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
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Assumptions
+-----------
+
+The special pattern character "*" is specified to "Match any sequence of char-
+acters". Does this include a zero-length sequence? In the absence of further
+information the answer is assumed to be Yes.
+
+The Task description does not specify whether the empty string is a legal
+pattern. For the sake of convenience, the empty string is here disallowed as a
+pattern (but it is allowed for $S, in which case the output will always be 0).
+
+Solution
+--------
+
+Advantage is taken of Perl's built-in regular expression functionality: $P is
+transformed into a regex pattern by substituting "." for "?" and ".*" for "*",
+respectively.
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+
+const my $USAGE =>
+"Usage:
+  perl $0 <S> <P>
+
+    <S>    A string
+    <P>    A pattern (non-empty string)\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 099, Task #1: Pattern Match (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my ($S, $P) = parse_command_line();
+
+    print qq[Input:  \$S = "$S" \$P = "$P"\n];
+
+    $P =~ s/ \? /./gx;
+    $P =~ s/ \* /.*/gx;
+
+    printf "Output: %d\n", $S =~ / ^ $P $ /x ? 1 : 0;
+}
+
+#------------------------------------------------------------------------------
+sub parse_command_line
+#------------------------------------------------------------------------------
+{
+    my $args = scalar @ARGV;
+       $args == 2 or error( "Expected 2 command-line arguments, found $args" );
+
+    my ($S, $P) = @ARGV;
+
+    length $P > 0 or error( 'The pattern string must not be empty' );
+
+    return ($S, $P);
+}
+
+#------------------------------------------------------------------------------
+sub error
+#------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+###############################################################################
diff --git a/challenge-099/athanasius/perl/ch-2.pl b/challenge-099/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..bb7d727d7d
--- /dev/null
+++ b/challenge-099/athanasius/perl/ch-2.pl
@@ -0,0 +1,204 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 099
+=========================
+
+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.
+
+*UPDATE: 2021-02-08 09:00AM (UK TIME) suggested by Jonas Berlin, missing entry
+[5].*
+
+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]
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Algorithm: Recursive search. The subroutine fine_subseqs() searches $S for the
+first character in $T, and then recursively searches the remainder of $S for
+the remainder of $T. The recursion ends when either $S or $T is exhausted. (In
+the first case, no match was found; in the second case, a match has been found
+and is recorded in the @subseqs array.)
+
+Note: If $VERBOSE is set to True, details of all the different subsequences
+found are displayed after the Output, as in the Examples. This is done using
+the subroutine partition(), which inserts square brackets around those charac-
+ters in $S which form a given subsequence.
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use feature qw( state );
+use Const::Fast;
+
+const my $VERBOSE => 1;
+const my $USAGE   =>
+"Usage:
+  perl $0 <S> <T>
+
+    <S>    Non-empty string to be searched
+    <T>    Non-empty substring to search for in \$S\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 099, Task #2: Unique Subsequence (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my ($S, $T) = parse_command_line();
+
+    print qq[Input:  \$S = "$S", \$T = "$T"\n];
+
+    my @subseqs;
+    my $subseqs = 0;
+
+    if (length $T <= length $S)  # No match is possible if $T is longer than $S
+    {
+        find_subseqs( $S, 0, $T, \@subseqs );
+        $subseqs = scalar @subseqs;
+    }
+
+    print "Output: $subseqs\n";
+
+    if ($VERBOSE && $subseqs > 0)
+    {
+        my $count = 0;
+
+        print  "\n";
+        printf "    %d: %s\n", ++$count, partition( $S, $_ ) for @subseqs;
+    }
+}
+
+#------------------------------------------------------------------------------
+sub find_subseqs                                         # Recursive subroutine
+#------------------------------------------------------------------------------
+{
+    state $seq = [];
+
+    my ($s, $i, $t, $subseqs) = @_;
+
+    # (1) Separate the search substring into $t0, its first character, and
+    #     $t_rem, the remaining characters (if any)
+
+    my ($t_0, $t_rem) = $t =~ / ^ (.) (.*) $ /x;
+
+    # (2) Beginning with the character at index $i, check each remaining
+    #     character in $s as a possible match for $t0: if it matches, add the
+    #     character's index ($j) to the array @$seq and recursively search the
+    #     remainder of $s for the substring $t_rem
+
+    for my $j ($i .. length($s) - 1)
+    {
+        if ($t_0 eq substr $s, $j, 1)
+        {
+            push @$seq, $j;                 # Add index $j to the sequence
+
+            if (length $t_rem == 0)
+            {
+                push @$subseqs, [ @$seq ];  # Copy the sequence and record it
+            }
+            else
+            {
+                find_subseqs( $s, $j + 1, $t_rem, $subseqs );  # Recursive call
+            }
+
+            pop @$seq;                      # Remove index $j from the sequence
+        }
+    }
+}
+
+#------------------------------------------------------------------------------
+sub partition
+#------------------------------------------------------------------------------
+{
+    my ($S, $seq)  = @_;
+    my  @partition = split //, $S;
+
+    # (1) Add square brackets around each character in the subsequence
+
+    for my $i (@$seq)
+    {
+        $partition[ $i ] = ' [' . $partition[ $i ] . '] ';
+    }
+
+    # (2) Remove initial and trailing spaces, and brackets and spaces internal
+    #     to a sequence of contiguous characters. E.g., " [l]  [i]  [t] tleit"
+    #     becomes  "[lit] tleit"
+
+    my $partition =  join '', @partition;
+       $partition =~ s{ \] \s{2} \[ }{}gx;  # Remove internal brackets & spaces
+       $partition =~ s{  ^ \s       }{}x;   # Remove initial  space
+       $partition =~ s{    \s  $    }{}x;   # Remove trailing space
+
+    return $partition;
+}
+
+#------------------------------------------------------------------------------
+sub parse_command_line
+#------------------------------------------------------------------------------
+{
+    my $args = scalar @ARGV;
+       $args == 2 or error( "Expected 2 command-line arguments, found $args" );
+
+    my ($S, $T) = @ARGV;
+
+    length $S > 0 or error( '$S is empty' );
+    length $T > 0 or error( '$T is empty' );
+
+    return ($S, $T);
+}
+
+#------------------------------------------------------------------------------
+sub error
+#------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+###############################################################################
diff --git a/challenge-099/athanasius/raku/ch-1.raku b/challenge-099/athanasius/raku/ch-1.raku
new file mode 100644
index 0000000000..ad678fd58f
--- /dev/null
+++ b/challenge-099/athanasius/raku/ch-1.raku
@@ -0,0 +1,118 @@
+use v6d;
+
+###############################################################################
+=begin comment
+
+Perl 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
+
+=end comment
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=begin comment
+
+Assumptions
+-----------
+
+The special pattern character "*" is specified to "Match any sequence of char-
+acters". Does this include a zero-length sequence? In the absence of further
+information the answer is assumed to be Yes.
+
+The Task description does not specify whether the empty string is a legal
+pattern. For the sake of convenience, the empty string is here disallowed as a
+pattern (but it is allowed for $S, in which case the output will always be 0).
+
+Note: On the Windows command line (i.e., using cmd.exe), it is not (always)
+possible to specify a single "*" as the pattern. See the Perl Monks thread:
+
+    "[Raku] Asterisk on DOS command line"
+     [https://www.perlmonks.com/index.pl?node_id=11128174]
+
+(Raku's treatment of * on the DOS command-line apparently depends on Rakudo's
+build environment.)
+
+Solution
+--------
+
+Advantage is taken of Raku's built-in regular expression functionality: $P is
+transformed into a regex pattern by substituting "." for "?" and ".*" for "*",
+respectively.
+
+=end comment
+#==============================================================================
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    "\nChallenge 099, Task #1: Pattern Match (Raku)\n".put;
+}
+
+#==============================================================================
+sub MAIN
+(
+    Str:D $S,                                   #= A string
+    Str:D $P is copy where { $P.chars > 0 }     #= A pattern (non-empty string)
+)
+#==============================================================================
+{
+    qq[Input:  \$S = "$S" \$P = "$P"].put;
+
+    $P ~~ s :g / \? /./;
+    $P ~~ s :g / \* /.*/;
+
+    "Output: %d\n".printf: $S ~~ rx/ ^ <$P> $ / ?? 1 !! 0;
+}
+
+#------------------------------------------------------------------------------
+sub USAGE()
+#------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+##############################################################################
diff --git a/challenge-099/athanasius/raku/ch-2.raku b/challenge-099/athanasius/raku/ch-2.raku
new file mode 100644
index 0000000000..822bfebf81
--- /dev/null
+++ b/challenge-099/athanasius/raku/ch-2.raku
@@ -0,0 +1,185 @@
+use v6d;
+
+###############################################################################
+=begin comment
+
+Perl Weekly Challenge 099
+=========================
+
+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.
+
+*UPDATE: 2021-02-08 09:00AM (UK TIME) suggested by Jonas Berlin, missing entry
+[5].*
+
+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]
+
+=end comment
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=begin comment
+
+Algorithm: Recursive search. The subroutine fine-subseqs() searches $S for the
+first character in $T, and then recursively searches the remainder of $S for
+the remainder of $T. The recursion ends when either $S or $T is exhausted. (In
+the first case, no match was found; in the second case, a match has been found
+and is recorded in the @subseqs array.)
+
+Note: If $VERBOSE is set to True, details of all the different subsequences
+found are displayed after the Output, as in the Examples. This is done using
+the subroutine partition(), which inserts square brackets around those charac-
+ters in $S which form a given subsequence.
+
+=end comment
+#==============================================================================
+
+my Bool constant $VERBOSE = True;
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    "\nChallenge 099, Task #2: Unique Subsequence (Raku)\n".put;
+}
+
+#==============================================================================
+sub MAIN
+(
+    Str:D $S where { $S.chars > 0 },  #= Non-empty string to be searched
+    Str:D $T where { $S.chars > 0 }   #= Non-empty substring to search for in S
+)
+#==============================================================================
+{
+    qq[Input:  \$S = "$S", \$T = "$T"].put;
+
+    my Array[UInt] @subseqs;
+    my UInt        $subseqs = 0;
+
+    if $T.chars <= $S.chars      # No match is possible if $T is longer than $S
+    {
+        find-subseqs( $S, 0, $T, @subseqs );
+        $subseqs = @subseqs.elems;
+    }
+
+    "Output: $subseqs".put;
+
+    if $VERBOSE && $subseqs > 0
+    {
+        my UInt $count = 0;
+
+        "\n".print;
+        "    %d: %s\n".printf: ++$count, partition( $S, $_ ) for @subseqs;
+    }
+}
+
+#------------------------------------------------------------------------------
+sub find-subseqs                                     #  Recursive subroutine
+(
+    Str:D                    $s,                     #= String to be searched
+    UInt:D                   $i,                     #= Start index for search
+    Str:D                    $t,                     #= Substring to search for
+    Array:D[Array:D[UInt:D]] $subseqs                #= Subsequences found
+)
+#------------------------------------------------------------------------------
+{
+    state UInt @seq;
+
+    # (1) Separate the search substring into $t0, its first character, and
+    #     $t-rem, the remaining characters (if any)
+
+    $t ~~ / ^ (.) (.*) $ /;
+    my Str ($t0, $t-rem) = $/.map: { .Str };
+
+    # (2) Beginning with the character at index $i, check each remaining
+    #     character in $s as a possible match for $t0: if it matches, add the
+    #     character's index ($j) to the array @seq and recursively search the
+    #     remainder of $s for the substring $t-rem
+
+    for $i .. $s.chars - 1 -> UInt $j
+    {
+        if $t0 eq $s.substr: $j, 1
+        {
+            @seq.push: $j;                  # Add index $j to the sequence
+
+            if $t-rem.chars == 0
+            {
+                $subseqs.push: @seq.clone;  # Copy the sequence and record it
+            }
+            else
+            {
+                find-subseqs( $s, $j + 1, $t-rem, $subseqs );  # Recursive call
+            }
+
+            @seq.pop;                       # Remove index $j from the sequence
+        }
+    }
+}
+
+#------------------------------------------------------------------------------
+sub partition( Str:D $S, Array:D[UInt:D] $seq --> Str:D )
+#------------------------------------------------------------------------------
+{
+    my Str @partition = $S.split: '', :skip-empty;
+
+    # (1) Add square brackets around each character in the subsequence
+
+    for @$seq -> UInt $i
+    {
+        @partition[ $i ] = ' [' ~ @partition[ $i ] ~ '] ';
+    }
+
+    # (2) Remove initial and trailing spaces, and brackets and spaces internal
+    #     to a sequence of contiguous characters. E.g., " [l]  [i]  [t] tleit"
+    #     becomes  "[lit] tleit"
+
+    my Str $partition = @partition.join: '';
+
+    $partition ~~ s :g / \] \s ** 2 \[ //;  # Remove internal brackets & spaces
+    $partition ~~ s    /  ^ \s         //;  # Remove initial  space
+    $partition ~~ s    /    \s $       //;  # Remove trailing space
+
+    return $partition;
+}
+
+#------------------------------------------------------------------------------
+sub USAGE()
+#------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+##############################################################################