These are some answers to the Week 100 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Task 1: Fun Time

You are given a time (12 hour / 24 hour).

Write a script to convert the given time from 12 hour format to 24 hour format and vice versa.

Ideally we expect a one-liner.

Example 1:

Input: 05:15 pm or 05:15pm
Output: 17:15

Example 2:

Input: 19:15
Output: 07:15 pm or 07:15pm

Well, I like concise code, but I don’t think it makes real sense to try to pack this task into a one-liner. I have no doubt that it can be done, but it will either be not a real one-liner (like a pipeline chaining multiple statements into one expression), or a difficult to understand golfing attempt. So, I will not try to do a one-liner.

Fun Time in Raku

We use a regex to detect whether the input string matches “am” or “pm”; if so, we remove that “am” or “pm” string and add 12 hours if the matched string was “pm”; otherwise, we subtract 12 from the hour part it if is larger than 12 and add “pm” or “am” depending on the case.

use v6;

my $time = @*ARGS[0];
if $time ~~ /(<[ap]>)m/ {
    if $0 eq 'a'  {
        $time ~~ s/(\d\d':'\d\d).*/$0/;
    } else {
        $time ~~ s/(\d\d)':'(\d\d).*/{$0 + 12}:$1/;
    }
} else {
    $time ~~ /^(\d\d)':'(\d\d)/;
    my ($suffix, $hour) = $0 > 12 ?? ('pm', $0 - 12) !! ('am', $0);
    $time = "$hour:$1 $suffix";
}
say $time;

These are some execution examples with various input strings:

$ raku fun-time.raku '10:54'
10:54 am
-
$ raku fun-time.raku '17:54'
5:54 pm
-
$ raku fun-time.raku '10:54 pm'
22:54
-
$ raku fun-time.raku '10:54 am'
10:54

Fun Time in Perl

This is a port to Perl of the Raku program just above:

use strict;
use warnings;
use feature "say";

my $time = shift;
if ($time =~ /([ap])m/) {
    if ($1 eq 'a')  {
        $time =~ s/(\d\d:\d\d).*/$1/;
    } else {
        $time =~ /(\d\d):(\d\d.).*/;
        my $hour = $1 + 12;
        $time = "$hour:$2";
    }
} else {
    $time =~ /^(\d\d):(\d\d)/;
    my ($suffix, $hour) = $1 > 12 ? ('pm', $1 - 12) : ('am', $1);
    $time = "$hour:$2 $suffix";
}
say $time;

And some execution examples:

$ perl fun-time.pl '10:54 pm'
22:54

$ perl fun-time.pl '10:54 am'
10:54

$ perl fun-time.pl '10:54'
10:54 am

$ perl fun-time.pl '15:54'
3:54 pm

Task 2: Triangle Sum

You are given triangle array.

Write a script to find the minimum path sum from top to bottom.

When you are on index i on the current row then you may move to either index i or index i + 1 on the next row.

Example 1:

Input: Triangle = [ [1], [2,4], [6,4,9], [5,1,7,2] ]
Output: 8

Explanation: The given triangle

            1
           2 4
          6 4 9
         5 1 7 2

The minimum path sum from top to bottom:  1 + 2 + 4 + 1 = 8

             [1]
           [2]  4
           6 [4] 9
          5 [1] 7 2

Example 2:

Input: Triangle = [ [3], [3,1], [5,2,3], [4,3,1,3] ]
Output: 7

Explanation: The given triangle

            3
           3 1
          5 2 3
         4 3 1 3

The minimum path sum from top to bottom: 3 + 1 + 2 + 1 = 7

             [3]
            3  [1]
           5 [2] 3
          4 3 [1] 3

Triangle Sum in Raku

We use the traverse recursive subroutine to find the smallest path through the triangular array:

use v6;

my @triangle = (1), (2,4), (6,4,9), (5,1,7,2);
my @min-path = map { $_[0] }, @triangle; # pick any path
my $min-path-val = @min-path.sum;
my $index = 0;
traverse @triangle, (), $index;
say @min-path;

sub traverse (@triangle, @path, $index) {
    my @first-line = @triangle[0];
    my @new-triangle = @triangle[1 .. @triangle.end];
    say "First-line: ", @first-line;
    my @new-path = | (@path, @first-line[$index]);
    say @new-path, "  ", "\n";
    if @new-triangle.elems > 0 {
        traverse(@new-triangle, @new-path, $index);
        traverse(@new-triangle, @new-path, $index + 1);
    } else {
        my $new-path-val = @new-path.sum;
        if $new-path-val < $min-path-val {
            @min-path = @new-path;
            $min-path-val = $new-path-val
        }
    }
}

Output:

$ raku triangle-sum.raku 1 2 4 1

Triangle Sum in Perl

Except for the fact that we define also a sum subroutine, this essentially the same Raku algorithm ported to Perl:

use strict;
use warnings;
use feature "say";

my $triangle = [ [1], [2,4], [6,4,9], [5,1,7,2] ];
# $triangle = [ [1], [2,4], [6,30,9], [30,30,30,2] ];
my $min_path = [ map { $_->[0] } @$triangle];
my $min_path_val = sum($min_path);
my $index = 0;
find_min_path($triangle, [], $index);
say "@$min_path";

sub sum {
    my $aref = shift;
    my $sum = 0;
    $sum += $_ for @$aref;
    return $sum;
}

sub find_min_path {
    my ($tri_ref, $path, $index) = @_;
    my @triangle = @$tri_ref;
    my @first_row = @{$triangle[0]};
    my @new_triangle = @triangle[1 .. $#triangle];
    my $new_path = [ @$path, $first_row[$index] ];
    if (@new_triangle) {
        find_min_path([@new_triangle], $new_path , $index);
        find_min_path([@new_triangle], $new_path, $index + 1);
    } else { 
        my $new_path_val = sum($new_path);
        if ($new_path_val < $min_path_val) {
            $min_path = $new_path;
            $min_path_val = $new_path_val;
        }
    }
}

Output with the above input data:

$ perl  triangle-sum.pl
1 2 4 1

If you uncomment the second triangle definition, you get the following output:

$ perl  triangle-sum.pl
1 4 9 2

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, February 28, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 99 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (February 14, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Pattern Match

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

So the pattern are similar to those used in the Unix ls command, with literal match for letters, digits and other characters common used in file names, and two wild-card characters, ? for any single character, and * for any sequence of characters.

Both in Raku and Perl, we will build a regex pattern by replacing * with the .* regex sequence, and ? with the . regex wild-card character. In addition, since we are requested to match the entire string, we will add the ^ start of string and $ end of string regex anchors.

Pattern Match in Raku

We could use regex substitutions to build the regex pattern (as we did below for the pattern match in Perl solution), but, here, the match subroutine loops through the input pattern characters and construct the regex pattern by hand. This subroutine finally applies regex matching to the input string.

use v6;

my $in = "abcde";
my @test-patterns = <a*e a*d ?b*d a*c?e>;
for @test-patterns -> $test {
    say "$test: ", match $test, $in;
}

sub match (Str $pattern, Str $in) {
    my $regex = 
        join "", gather {
            take '^';
            for $pattern.comb {
                when '*' { take '.*' }
                when '?' { take '.'  }
                default  { take $_   }
            }
            take '$';
    }
    return  $in ~~ /<$regex>/ ?? 1 !! 0;
}

With the “abcde” input string and the four input patterns, this program displays the following output:

$ raku pattern-match.raku
a*e: 1
a*d: 0
?b*d: 0
a*c?e: 1

Pattern Match in Perl

As mentioned above, I decided here to use regex substitutions to convert the input pattern into a regex pattern.

use strict;
use warnings;
use feature "say";

my $input = "abcde";
my @test_patterns = qw/a*e a*d ?b*d a*c?e/;
for my $pat (@test_patterns) {
    say "$pat: ", match($input, $pat)
}

sub match {
    my ($in, $pattern) = @_;
    $pattern =~ s/\*/.*/g;
    $pattern =~ s/\?/./g;
    $pattern = "^$pattern\$";
    return $in =~ /$pattern/ ? 1 : 0;
}

This program displays the same output as the Raku program above:

$ perl match-pattern.pl
a*e: 1
a*d: 0
?b*d: 0
a*c?e: 1

Task 2: Unique Subsequence

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:00 AM (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]

Dear Mohammad, when you do such updates, would you please be kind enough to send an e-mail informing us of such change. I had loaded the web page before the update, and spent a couple of hours trying to fix my program against your solution until I found that, in fact, my program was correct and your initial solution wrong. Only at that point did I think about re-loading the page and found that you had fixed the solution on the Web page. Every one can make mistakes, I have no problem with that, but please inform us when this happens.

Unique Subsequence in Raku

Although I admit that there may be some more efficient solution in terms of speed performance, I felt that using brute force with the combinations built-in method was better in terms of coding efficiency. The program generates all the input letters combinations having the size of the searched substring, filters out those not matching the input substring, and finally returns the number of matching substrings.

use v6;

my @input-tests = [ "littleit", "lit"], ["london", "lon"];

for @input-tests -> $test {
    my ($in, $substr) = $test[0..1];
    say "$test: ", search-substr $in, $substr;
}
sub search-substr (Str $in, Str $substr) {
    my @results = $in.comb.combinations($substr.\
        chars)>>.join("").grep({$_ eq $substr}).elems;
}

All the real work is done in a single code line (well, formatted here over two lines for a better graphical rendering on this blog page).

This program displays the following output:

$ ./raku subsequence.raku
littleit lit: [5]
london lon: [3]

Unique Subsequence in Perl

The solution in Perl is completely different from the Raku solution. Here, we use the search_substr recursive subroutine to explore all the possible substrings. This program could generate all the letter combinations as the Raku program, except that it cuts the process for any letter combination that will never eventually match the search substring, so that the program is doing much less useless work. Presumably this should make the program faster, especially for longer input strings and substrings.

use strict;
use warnings;
use feature "say";

my @input_tests = ( [ "littleit", "lit"], ["london", "lon"], ["aaaa", "aa"]);
my $count;
for my $in (@input_tests) {
    $count = 0;
    search_substr (@$in);
    say "@$in: $count";
}
sub search_substr {
    my ($in, $searched) = @_; 
    my $start = substr $searched, 0, 1;
    my $index = 0;
    while (1) {
        $index = index $in, $start, $index;
        return if $index < 0;
        $index++;
        ++$count and next  if length $searched == 1;
        search_substr (substr($in, $index), substr($searched, 1));      
    }
}

This programs displays the following output:

$ perl subsequence.pl
littleit lit: 5
london lon: 3
aaaa aa: 6

Wrapping up

The next week Perl Weekly Challenge will start soon and will be the 100th challenge. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, February 21, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 98 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Task 1: Read N-characters

You are given file $FILE.

Create subroutine readN($FILE, $number) that returns the first n-characters and moves the pointer to the (n+1)th character.

Example:

Input: Suppose the file (input.txt) contains "1234567890"
Output:
    print readN("input.txt", 4); # returns "1234"
    print readN("input.txt", 4); # returns "5678"
    print readN("input.txt", 4); # returns "90"

Read N-characters in Raku

This is my first attempt:

use v6;

my $input = @*ARGS[0] // "I_have_a_dream.txt";

given $input.IO.open {
    for 0..2 -> $num {
        my $n = (1..10).pick;
        say "Taking $n characters: ", .readchars: $n;
    }
}

Using Martin Luther King's 1963 famous "I have a dream" speech at the Lincoln Memorial in Washington as an input file, I obtain the following output:

$ raku read_n_chars.raku
Taking 3 characters: I a
Taking 3 characters: m h
Taking 4 characters: appy

$ raku read_n_chars.raku
Taking 3 characters: I a
Taking 5 characters: m hap
Taking 9 characters: py to joi

However, my understanding of the challenge is that, maybe, Mohammad S. Anwar wanted us to implement an iterator, rather than using a Raku built-in subroutines implementing such iterators.

To do that, I wrote a create-iter subroutine iterating over the file contents:

use v6;

my $input = @*ARGS[0] // "I_have_a_dream.txt";

sub create-iter ($file-in) {
    my $counter = 0;
    my $content = $file-in.IO.slurp;
    return sub (Int $length) {
        my $out = substr $content, $counter, $length;
        $counter += $length;
        return $out;
    }
}
my &iterator = create-iter $input;       
for 0..2 -> $num {
    my $n = (1..10).pick;
    say "Taking $n characters: ", &iterator($n);
}

Example output:

$ raku read_n_chars2.raku
Taking 8 characters: I am hap
Taking 6 characters: py to
Taking 9 characters: join with

Read N-characters in Perl

This is a Perl implementation of the first Raku program above:

use strict;
use warnings;
use feature qw/say/;

my $input = shift // "I_have_a_dream.txt";
open my $IN, "<", $input or die "Cannot open $input $!";
for my $n (4..7) {
    say "Taking $n characters: ", map getc $IN, 1..$n;
}

Example output:

$ perl read_n_chars1.pl
Taking 4 characters: I am
Taking 5 characters:  happ
Taking 6 characters: y to j
Taking 7 characters: oin wit

And here is a solution implementing an iterator:

use strict;
use warnings;
use feature qw/say/;

sub create_iter {
    my $input = shift;
    my $counter = 0;
    open my $IN, '<', $input or die "Couldn't open $input $!";
    local $/ = undef;   # enabling "slurping mode"
    my $content = <$IN>; # slurping the file
    return sub {
        my $length = shift;
        my $out = substr $content, $counter, $length;
        $counter += $length;
        return $out;
    }
}
my $in = shift // "I_have_a_dream.txt";
my $iterator = create_iter $in;       
for my $n (3..5) {
    say "Taking $n characters: ", $iterator->($n);
}

Task 21: Search Insert Position

You are given a sorted array of distinct integers @N and a target $N.

Write a script to return the index of the given target if found otherwise place the target in the sorted array and return the index.

Example 1:

Input: @N = (1, 2, 3, 4) and $N = 3
Output: 2 since the target 3 is in the array at the index 2.

Example 2:

Input: @N = (1, 3, 5, 7) and $N = 6
Output: 3 since the target 6 is missing and should be placed at the index 3.

Example 3:

Input: @N = (12, 14, 16, 18) and $N = 10
Output: 0 since the target 10 is missing and should be placed at the index 0.

Example 4:

Input: @N = (11, 13, 15, 17) and $N = 19
Output: 4 since the target 19 is missing and should be placed at the index 4.

Search Insert Position in Raku

This is a simple implementation in Raku:

use v6;

my @tests = [3,  < 1  2  3  4>],
            [6,  < 1  3  5  7>],
            [10, <12 14 16 18>],
            [19, <11 13 15 17>];
for @tests -> $test {
    say $test.gist.fmt("%-20s:\t"), find_insert-pos ($test);
}
sub find_insert-pos ($test) {
    my $target = $test[0];
    my @array = |$test[1];
    for 0..@array.end -> $i {
        return $i if @array[$i] >= $target;
    }
    return @array.end + 1;
}

Output:

$ raku search_insert_pos.raku
[3 (1 2 3 4)]       :   2
[6 (1 3 5 7)]       :   3
[10 (12 14 16 18)]  :   0
[19 (11 13 15 17)]  :   4

This implementation is somewhat inefficient when the input data is large. I made a better binary search implementation, but I am so late that I can't really present it.

Search Insert Position in Perl

Update: I was so late when I originally posted this that I did not have time to include the Perl program for this task. Here it is:

use strict;
use warnings;
use feature "say";

my @tests = ( [3,  qw < 1  2  3  4>],
              [6,  qw < 1  3  5  7>],
              [10, qw <12 14 16 18>],
              [19, qw <11 13 15 17>],
            );
for my $test (@tests) {
    say "$test->[0], @{$test}[1..@{$test}-1]: ", find_insert_pos ($test);
}
sub find_insert_pos {
    my ($target, @array) = @{$_[0]};
    for my $i (0..$#array) {
        return $i if $array[$i] >= $target;
    }
    return $#array + 1;
}

Output:

$ perl  search_insert_pos.pl
3, 1 2 3 4: 2
6, 1 3 5 7: 3
10, 12 14 16 18: 0
19, 11 13 15 17: 4

Search Insert Position in Python

This is a port to Python of the Raku and Perl programs above:

def find_insert_pos(target, list):
    for i in range(len(list)):
        if list[i] >= target:
            return i 
    return len(list)

in_list = [1, 3, 5, 7]
for j in range (8):
    print('Target: ', j, '->', find_insert_pos(j, in_list))

Output:

$ python3 search_insert_pos.py
Target:  0 -> 0
Target:  1 -> 0
Target:  2 -> 1
Target:  3 -> 1
Target:  4 -> 2
Target:  5 -> 2
Target:  6 -> 3
Target:  7 -> 3

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, February 14, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.