Solutions to challenge 099

2 files changed, 225 insertions, 0 deletions

diff --git a/challenge-099/jo-37/perl/ch-1.pl b/challenge-099/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..5125ed3951
--- /dev/null
+++ b/challenge-099/jo-37/perl/ch-1.pl
@@ -0,0 +1,118 @@
+#!/usr/bin/perl -s
+
+use v5.20;
+use Test2::V0;
+use experimental 'signatures';
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV == 2;
+usage: $0 [-examples] [-tests] [-verbose] [string pattern]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    print generated regex
+
+string
+    string to be matched against pattern
+
+pattern
+    shell-like pattern
+
+Use '?' inside pattern to match one arbitrary character, '*' to match
+any number of characters and '\\' to interpret the following single
+character literally.
+
+EOS
+
+
+### Input and Output
+
+say patmatch($ARGV[0], $ARGV[1]) + 0;
+
+
+### Implementation
+
+# Convert pattern part to regex:
+# *  -> .*
+# ?  -> .
+# \x -> x
+# other: quote if necessary
+#
+# Processes $_.
+sub convmeta {
+    return '.*?' if /^\*$/;
+    return '.' if /^\?$/;
+    return quotemeta $1 if /^\\(.)$/;
+    # else:
+    quotemeta;
+}
+
+# Match string against pattern.  Pattern meta characters are:
+# ? : match one character
+# * : match any number of characters
+# \ : use next character literally
+# The special treatment of quoted characters is beyond the specification
+# of this task but it seems to be useful and needful.
+sub patmatch ($str, $pat) {
+
+    # Convert pattern to regex.
+    my $re =  sub {qr/^ @_ $/x}->(
+        map convmeta,
+        $pat =~ m{
+            \G              # start at previous end-of-match position and
+            (               # capture
+                [^*?\\]+    # a group of non-meta chars
+              |             # or    
+                [*?]        # a meta-char
+              |             # or
+                \\.         # a quoted char
+            )
+        }gx);
+    # Reject incomplete patterns.
+    die "invalid pattern: '$'' in '$pat'" if $';
+    
+    say "pattern: '$pat'\nregex:   $re" if $verbose;
+    
+    $str =~ $re;
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+        ok patmatch('abcde', 'a*e'), 'example 1';
+        ok !patmatch('abcde', 'a*d'), 'example 2';
+        ok !patmatch('abcde', '?b*d'), 'example 3';
+        ok patmatch('abcde', 'a*c?e'), 'example 4';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        ok patmatch('ch-1.pl', '*.pl'), 'literal dot matches';
+        ok !patmatch('ch-1-pl', '*.pl'), 'literal dot only matches dot';
+        ok patmatch('abc.*', '*.\*'), 'literal asterisk matches';
+        ok !patmatch('abc.pl', '*.\*'), 'literal asterisk required';
+        ok patmatch('ch-[12].pl', '*-[12].pl'), 'literal charclass matches';
+        ok !patmatch('ch-1.pl', '*-[12].pl'), 'literal charclass required';
+        ok patmatch('ch-1.pl', '*.\p\l'), 'escaped characters';
+        ok patmatch('ab\\cd', '??\\\\??'), 'escaped backslash';
+        ok patmatch('abbccdde', 'a?*?*?e'), 'matching consecutive meta chars';
+        ok !patmatch('abde', 'a?*?*?e'), 'non-matching consecuteive meta chars';
+        ok patmatch('äöü', 'ä?ü'), 'handle multi-byte characters';
+        like dies {patmatch('ab', 'ab\\')}, qr/invalid pattern/,
+            'incomplete quoting sequence';
+	}
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-099/jo-37/perl/ch-2.pl b/challenge-099/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..9f7e22f188
--- /dev/null
+++ b/challenge-099/jo-37/perl/ch-2.pl
@@ -0,0 +1,107 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use experimental 'signatures';
+use charnames ':full';
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV == 2;
+usage: $0 [-examples] [-tests] [-verbose] [string sequence]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    show subsequence in string
+
+string
+    string to examine
+
+sequence
+    sequence of chars to search for in <string>
+
+EOS
+
+
+### Input and Output
+
+say matchseq($ARGV[0], $ARGV[1]);
+
+
+### Implementation
+
+# Count occurences of a character sequence within a string.
+sub matchseq ($str, $seq) {
+
+    # Create a regex that matches the character sequence and captures
+    # all of its characters individually.
+    # Example transformation chain:
+    # 'x*' -> ('x', '*') -> ('x', '\\*') -> (?:(x).*?(\*))
+    my $seqmatch = sub {
+        local $" = ').*?(';
+        qr{(@_)};
+    }->(map quotemeta, split //, $seq);
+
+    # Find all sequence matches and collect the character match offsets.
+    my @match;
+    $str =~ m{ $seqmatch (?{push @match, [@-]}) (*FAIL) }x;
+
+    explainseq($str, $seq, $seqmatch, \@match) if $verbose;
+
+    # Return the number of matches.
+    scalar @match;
+}
+
+# Show the locations of the character sequence within the string.
+sub explainseq ($str, $seq, $re, $matches) {
+
+    say "sequence: '$seq'";
+    say "matcher:  $re";
+    say $str;
+
+    for my $match (@$matches) {
+
+        # Discard match offset, keeping submatches only. (See @-)
+        shift @$match;
+
+        # Prepare a string having the same length as $str.
+        my $seqloc = "\N{MIDDLE DOT}" x length $str;
+
+        # Overwrite the string at match offsets with chars from the
+        # sequence.
+        while (my ($idx, $offs) = each @$match) {
+            substr($seqloc, $offs, 1) = substr($seq, $idx, 1);
+        }
+        say $seqloc;
+    }
+}
+
+### Examples and tests
+
+sub run_tests {
+SKIP: {
+    skip "examples" unless $examples;
+    is matchseq('littleit', 'lit'), 5, 'example 1';
+    is matchseq('london', 'lon'), 3, 'example 2';
+}
+
+SKIP: {
+    skip "tests" unless $tests;
+    is matchseq('xxaxxbxxcxx', 'abc'), 1, 'unique sequence';
+    is matchseq('aaaaa', 'a'), 5, 'repetition';
+    is matchseq('ihgfedcba', 'def'), 0, 'not found';
+    is matchseq('a.b*c[d0e-f9g]h', '.*[0-9]'), 1, 'meta characters';
+        is matchseq('aa1', '.*[0-9]'), 0, 'not matching "regex"';
+        is matchseq('a.b.c', '.'), 2, 'matching literal dot'
+	}
+
+    done_testing;
+    exit;
+}