Merge pull request #3516 from ccntrq/challenge-099

Challenge 099

2 files changed, 188 insertions, 0 deletions

diff --git a/challenge-099/alexander-pankoff/perl/ch-1.pl b/challenge-099/alexander-pankoff/perl/ch-1.pl
new file mode 100755
index 0000000000..5694dfc922
--- /dev/null
+++ b/challenge-099/alexander-pankoff/perl/ch-1.pl
@@ -0,0 +1,70 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+{
+    if ( $ENV{TESTING} ) {
+        test_match();
+    }
+    else {
+        my ( $S, $P ) = @ARGV;
+        die "usage: $0 STRING PATTERN\n" unless @ARGV == 2;
+
+        say match( $S, $P ) ? 1 : 0;
+    }
+}
+
+sub test_match() {
+
+    my @test_cases = (
+        [ "abcde", "a*e",   1 ],
+        [ "abcde", "A*e",   0 ],
+        [ "abcde", "a*d",   0 ],
+        [ "abcde", "?b*d",  0 ],
+        [ "abcde", "a*c?e", 1 ],
+        [ "acde",  "a*c?e", 0 ],
+    );
+
+    require Test::More;
+    Test::More->import( tests => scalar @test_cases );
+
+    for my $test (@test_cases) {
+        my ( $string, $pattern, $expected ) = @{$test};
+        ok( match( $string, $pattern ) == $expected,
+            "$string does " . ( $expected ? '' : 'not ' ) . "match $pattern" );
+    }
+
+}
+
+# returns true if $string matches $pattern
+# returns false otherwise
+#
+# The following characters have a special meaning in the pattern:
+#  - ? - Match any single character.
+#  - * - Match any sequence of characters.
+#
+# The pattern match is case sensitive.
+sub match ( $string, $pattern ) {
+
+    # we will transform the pattern into a regex and use perls internal regex
+    # engine to perform the pattern matching for us.
+    # first we quote non word chars in the user provided pattern to prevent
+    # them from beeing interpreted as regex operators
+    my $re = quotemeta($pattern);
+
+    # then we convert that special chars into regex patterns.
+    # a `?` in the pattern should match a single char. In a regex we do this
+    # with a `.`. The `?` in the input has been prepended with a backslash by
+    # quotemeta. So we have to replace that aswell.
+    $re =~ s/\\\?/./g;
+
+    # a `*` should match any sequence of chars. We do this by replacing each
+    # `*` with a `.+` regex pattern
+    $re =~ s/\\\*/.+/g;
+
+    return $string =~ m/^$re$/;
+}
diff --git a/challenge-099/alexander-pankoff/perl/ch-2.pl b/challenge-099/alexander-pankoff/perl/ch-2.pl
new file mode 100755
index 0000000000..2e491e003b
--- /dev/null
+++ b/challenge-099/alexander-pankoff/perl/ch-2.pl
@@ -0,0 +1,118 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+{
+    if ( $ENV{TESTING} ) {
+        test_count_subsequences();
+    }
+    else {
+        my ( $S, $T ) = @ARGV;
+        die "usage: $0 STRING STRING\n" unless @ARGV == 2;
+
+        say count_subsequences( $S, $T );
+    }
+}
+
+sub test_count_subsequences() {
+
+    my @test_cases = ( [ "littleit", "lit", 5 ], [ "london", "lon", 3 ], );
+
+    require Test::More;
+    Test::More->import( tests => scalar @test_cases );
+
+    for my $test (@test_cases) {
+        my ( $string, $target, $count ) = @{$test};
+        ok(
+            count_subsequences( $string, $target ) == $count,
+            "$string contains $count subsequences matching $target"
+        );
+    }
+}
+
+# This implementation was done after reading @jacoby 's blog where he explains
+# his solution.  You can find the blog and a decent explanation of the
+# recursive process here:
+# https://jacoby.github.io/2021/02/11/london-patterns-perl-weekly-challenge-99.html
+# To add something new to his idea I have added the StringIterator class to
+# handle the position tracking.
+sub count_subsequences ( $string, $target ) {
+
+    # create a recurisve helper routine that works on StringIterator objects
+    my $go;
+    $go = sub ( $string_iterator, $target_iterator ) {
+        my $current = $string_iterator->next;
+
+        # we're at the end of the string
+        return 0 if !defined $current;
+
+        # recurse into the non matching case. here we have to clone our
+        # iterators to prevent modifications inside of the nested calls from
+        # affecting us here
+        # the $string_iterator has already been advanced by our call to next
+        # whereas the target_iterator is still in its original state
+        my $count = $go->( $string_iterator->clone, $target_iterator->clone );
+
+        # advance the target_iterator and get the current target char
+        my $target_char = $target_iterator->next;
+        if ( $current eq $target_char ) {
+
+            # we have a full match if the target_iterator is exhausted. We can
+            # increment the count and stop here.
+            if ( $target_iterator->is_at_end ) {
+                $count += 1;
+            }
+
+            # if we don't have a full match we have to recurse. both iterators
+            # have been advanced by now and won't be used anymore. we can pass
+            # them as is.
+            else {
+                $count += $go->( $string_iterator, $target_iterator, );
+            }
+        }
+
+        return $count;
+    };
+
+    # create the Iterator objects and go!
+    $go->( StringIterator->new($string), StringIterator->new($target) );
+}
+
+package StringIterator {
+
+    sub new ( $class, $string ) {
+        my $self = {
+            string   => $string,
+            position => 0,
+            size     => length($string),
+        };
+
+        return bless $self, $class;
+    }
+
+    # returns the current char and advances the iterator
+    # returns `undef` if the iterator is exhausted
+    sub next($self) {
+        return undef if $self->is_at_end();
+        my $char = substr( $self->{string}, $self->{position}, 1 );
+        $self->{position}++;
+        return $char;
+    }
+
+    # returns 1 if the iterator is at the end
+    #         0 otherwise
+    sub is_at_end($self) {
+        return 1 if $self->{position} >= $self->{size};
+        return 0;
+    }
+
+    # returns a clone of the iterator object
+    sub clone($self) {
+        return bless {%$self}, ref $self;
+    }
+}
+