From f903cc3deb967f6d08c0498144109a8b5b278f36 Mon Sep 17 00:00:00 2001 From: PerlMonk Athanasius Date: Sun, 14 Feb 2021 19:19:47 +1000 Subject: Perl & Raku solutions to Tasks 1 & 2 of the Perl Weekly Challenge #099 On branch branch-for-challenge-099 Changes to be committed: new file: challenge-099/athanasius/perl/ch-1.pl new file: challenge-099/athanasius/perl/ch-2.pl new file: challenge-099/athanasius/raku/ch-1.raku new file: challenge-099/athanasius/raku/ch-2.raku --- challenge-099/athanasius/perl/ch-1.pl | 132 +++++++++++++++++++++ challenge-099/athanasius/perl/ch-2.pl | 204 ++++++++++++++++++++++++++++++++ challenge-099/athanasius/raku/ch-1.raku | 118 ++++++++++++++++++ challenge-099/athanasius/raku/ch-2.raku | 185 +++++++++++++++++++++++++++++ 4 files changed, 639 insertions(+) create mode 100644 challenge-099/athanasius/perl/ch-1.pl create mode 100644 challenge-099/athanasius/perl/ch-2.pl create mode 100644 challenge-099/athanasius/raku/ch-1.raku create mode 100644 challenge-099/athanasius/raku/ch-2.raku 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

+ + A string +

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 + + Non-empty string to be searched + 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; +} + +############################################################################## -- cgit