August 2020 Archives

Perl Weekly Challenge 75: Coin Sums and Largest Rectangle Histogram

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (August 30, 2020). 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: Coins Sums

You are given a set of coins @C, assuming you have infinite amount of each coin in the set.

Write a script to find how many ways you make sum $S using the coins from the set @C.

Example:

Input:
    @C = (1, 2, 4)
    $S = 6

Output: 6
There are 6 possible ways to make sum 6.
a) (1, 1, 1, 1, 1, 1)
b) (1, 1, 1, 1, 2)
c) (1, 1, 2, 2)
d) (1, 1, 4)
e) (2, 2, 2)
f) (2, 4)

Coin Sums in Raku

The first idea that might come to mind may be to use the combinations and/or permutations, or some combination thereof, to generate all the possible coin combinations and then to filter out those not matching the target value (and also remove duplicates). I’ve done that in some previous Perl Weekly Challenges. However, my experience tells me that, even for moderately large input data, this process would generate a lot, I really mean A LOT, of useless combinations leading to poor performance.

One alternative is to construct the various coin combinations by iterating over the possible values. If we knew in advance that we were going to have, say, three coin values, it would be very easy to implement three nested for loops to test all possible combinations. But when we don’t know in advance how many coin values we’re going to get, then it is usually much simpler to use a recursive subroutine. In the program below, the recursive find-sum subroutine loops over the input values and calls itself again for each of these values. The recursion stops when the sum obtained so far is equal to the target sum (in which case it stores the solution) or greater than it. The solutions obtained are sorted in ascending order, stringified and stored in a SetHash to remove any duplicate.

use v6;

my $target_sum = shift @*ARGS;
my @coins = sort @*ARGS;
my SetHash $result;
find-sum(0, []);
.say for $result.keys.sort;

sub find-sum (Int $start, @allocated-so-far) {
    return if $start > $target_sum;
    if $start == $target_sum {
        $result{join " ", sort @allocated-so-far}++;
        return;
    }
    for @coins -> $coin {
        my @new-allocated =  | @allocated-so-far, $coin;
        my $new-sum = $start + $coin;
        find-sum($new-sum, @new-allocated);
    }
}

This works fine for small input:

$ ./raku coin-sum.raku 6 1 2 4
1 1 1 1 1 1
1 1 1 1 2
1 1 2 2
1 1 4
2 2 2
2 4

However, if we set the target value to, say, 20 and use more coin values, the program starts to take quite a lot of time to run. For example, more than 27 seconds in the following example:

$ time raku coin-sum.raku 20 1 2 4 5
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2
(68 lines omitted for brevity)
4 4 4 4 4
5 5 5 5

real    0m27,397s
user    0m0,015s
sys     0m0,062s

The reason for this poor performance is that the program inspects a lot of values that turn out to be duplicates. For example, in the case of the first example above with a target value of 6, the program finds:

1 1 1 1 2

but it also tests:

1 1 1 2 1
1 1 2 1 2
1 2 1 1 1
2 1 1 1 1

All these values are really duplicates and are subsequently eliminated, but that’s a lot of useless work.

And it gets much worse for larger target values and larger coin value sets.

We can improve considerably the program’s performance if, rather subsequently eliminating duplicates, we avoid generating them in the first place. For this, we need to make sure that the coin values are in ascending order and use only coin values that are larger than or equal to the last coin value used so far. In other words, rather than generating all possible coin permutations, we will generate only the permutations in strict ascending order. And, as we’ll see, that’s a huge difference. We no longer need a SetHash to remove duplicates, an array will be sufficient to store the results. We no longer need to sort the coin values in each combination, we only need to sort the initial array of coin values. But since we no longer remove duplicates from the results, we also need to make sure there is no duplicate in the initial array of coin values.

use v6;

my $target_sum = shift @*ARGS;
my @coins = @*ARGS.sort.squish;
my @result;
find-sum(0, []);
.say for @result;

sub find-sum (Int $start, @allocated-so-far) {
    return if $start > $target_sum;
    if $start == $target_sum {
        push @result, join " ", @allocated-so-far;
        return;
    }
    my $last-coin = 0;
    $last-coin = @allocated-so-far[*-1] if defined @allocated-so-far[*-1];
    for @coins.grep({$_ >= $last-coin}) -> $coin {
        find-sum($start + $coin, (| @allocated-so-far, $coin));
    }
}

Remember that we had a runtime of about 27.4 second for a target value of 20 and four input coin values? We’re now down to about half a second with exactly the same input parameters:

$ time raku coin-sum2.raku 20 1 2 4 5
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2
(67 lines omitted for brevity)
2 4 4 5 5
4 4 4 4 4
5 5 5 5

real    0m0,537s
user    0m0,030s
sys     0m0,030s

Now, of course, we are talking of a process where we have an exponential (or rather factorial) combinatorial explosion. There are some inherent limits to the input size even when you improve considerably the algorithm. For example, with a target value of 50 and a few more coin values, we get this:

$ time raku coin-sum2.raku 50 1 2 4 5 6 7 8 | wc
   8466  159909  328284

real    0m20,867s
user    0m0,015s
sys     0m0,108s

There may be some possible pure-Raku micro-optimizations, but, against a combinational explosion, they will necessarily be wiped out by just a slightly larger input. Parallel processing might bring a performance improvement, but only marginally with an exponential process. Similarly, using C code will definitely help, but only to a quite limited extent.

Coin Sums in Perl

I have explained in the Raku section above some very significant performance improvements between my initial and my final Raku implementation. I’ll port to Perl the performance-improved version (please refer to the Raku section above for explanations about performance improvements):

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

my $target_sum = shift;
my $prev = 0;
my @coins = grep { $_ > $prev and $prev = $_}  sort { $a <=> $b } @ARGV;
die "Need at least two integer values" unless @coins;
my @result;
find_sum(0, ());
say for @result;

sub find_sum {
    my ($start, @allocated_so_far) = @_;
    return if $start > $target_sum;
    if ($start == $target_sum) {
        push @result, join " ", @allocated_so_far;
    } else {
        my $last_coin = $allocated_so_far[-1] // 0;
        for my $coin (grep $_ >= $last_coin, @coins) {      
            find_sum($start + $coin, @allocated_so_far, $coin);
        }
    }
}

The resulting output is as expected:

$ perl coin-sum.pl 6 1 2 3
1 1 1 1 1 1
1 1 1 1 2
1 1 1 3
1 1 2 2
1 2 3
2 2 2
3 3

With a larger input (target value of 20), the Perl program is 6 to 7 times faster than the Raku program. I’m sorry to have to say that, but, quite obviously, for such a CPU-intensive problem, there is still quite a bit of room for improvement in terms of Raku performance (compared to Perl).

Task 2: Largest Rectangle Histogram

You are given an array of positive numbers @A.

Write a script to find the larget rectangle histogram created by the given array.

BONUS: Try to print the histogram as shown in the example, if possible.

Example 1:

Input: @A = (2, 1, 4, 5, 3, 7)

     7           #
     6           #
     5       #   #
     4     # #   #
     3     # # # #
     2 #   # # # #
     1 # # # # # #
     _ _ _ _ _ _ _
       2 1 4 5 3 7

Looking at the above histogram, the largest rectangle (4 x 3) is formed by columns (4, 5, 3 and 7).

Output: 12

Let me start with a comment. Depending on the input data, there can be two or more rectangles having the same maximum area. Since the requested output is just the size of the rectangle, we obviously don’t care when there are several rectangles. That being said, I’ll nonetheless add to the output information about the range of values that produced the largest rectangle (or one of them when there are more than one). This make it easier to check that the results are correct. It would be quite easy to change that and list all the rectangles when there are more than one, but I preferred to spend my time making a program in a language (in addition to Raku and Perl) that has never been used so far in the Perl Weekly Challenge (see below) and that probably nobody in the team knows (besides me).

Finally, for the bonus, I slightly changed the output to also include the subscripts of the input array, as this also makes it a bit easier to verify the result.

Largest Rectangle Histogram in Raku

The method used is really brute force: trying all possible rectangles of the histogram. For example, we start with the first column (with value 2 in the above histogram). From this column, we can derive two rectangles!

2 #
1 #

and:

1 # # # # # #

The second one is the winner so far. Then we go to the next column (with value 1), and will obviously not get anything better. We move next to the third column (with value 4) and can find two better candidates:

4     # # 
3     # # 
2     # # 
1     # #

and:

3     # # # #
2     # # # #
1     # # # #

As it turns out, the second solution above is the best for the input data, but we don’t know yet, so we need to continue the process until we have exhausted all the possibilities.

use v6;

my @a = @*ARGS.elems > 1 ?? @*ARGS !! (2, 1, 4, 5, 3, 7);
draw-histo(@a);
my ($area, @rectangle) = largest-rect(@a);
say "Largest rectangle is @rectangle[] with an area of $area.";


sub draw-histo (@in) {
    my $max-val = @in.max;
    say "  ", join "  ", 0..@in.end;
    say "  -" x @in.elems;
    for (1..$max-val).reverse -> $ordinate {
        print $ordinate;
        for 0..@in.end -> $i {
            print @in[$i] >= $ordinate ?? " # " !! "   ";
        }
        say "";
    }
    say "  =" x @in.elems;
    say "  ", join "  ", @in;
}

sub largest-rect (@in) {
    my $largest_area = 0;
    my @best-vals = 0, 0;
    for 0..^@in.end -> $i {
        for $i^..@in.end -> $j {
            my $area = ($j - $i + 1) * @in[$i..$j].min;
            # say "testing $i $j $area";
            if $area > $largest_area {
                $largest_area = $area;
                @best-vals = $i, $j;
            }
        }
    }
    return $largest_area, @best-vals;
}

This is the displayed output for two different input data sets:

$ raku largest_rect.raku
  0  1  2  3  4  5
  -  -  -  -  -  -
7                #
6                #
5          #     #
4       #  #     #
3       #  #  #  #
2 #     #  #  #  #
1 #  #  #  #  #  #
  =  =  =  =  =  =
  2  1  4  5  3  7
Largest rectangle is 2 5 with an area of 12.


$ raku largest_rect.raku 5 6 3 4 2 7 9 8
  0  1  2  3  4  5  6  7
  -  -  -  -  -  -  -  -
9                   #
8                   #  #
7                #  #  #
6    #           #  #  #
5 #  #           #  #  #
4 #  #     #     #  #  #
3 #  #  #  #     #  #  #
2 #  #  #  #  #  #  #  #
1 #  #  #  #  #  #  #  #
  =  =  =  =  =  =  =  =
  5  6  3  4  2  7  9  8
Largest rectangle is 5 7 with an area of 21.

Largest Rectangle Histogram in Perl

This is a port to Perl of my Raku program above. The only significant difference is that I had to write my own min subroutine (I know that there exist modules to do that, but I do not want to use off-the-shelf third-party software packages for programming challenges).

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

my @a = @ARGV > 1 ? @ARGV : ( 2, 1, 4, 5, 3, 7);
draw_histo(@a);
my ($area, @rectangle) = largest_rect(@a);
say "Largest rectangle is @rectangle with an area of $area.";

sub draw_histo {
    my @in = @_;
    my $max_val = $in[0];
    for my $i (1..$#in) {
        $max_val = $in[$i] if $in[$i] > $max_val;
    }
    say "\n  ", join "  ", 0..$#in;
    say "  -" x scalar @in;
    for my $ordinate (reverse 1..$max_val) {
        print $ordinate;
        for my $i (0..$#in) {
            print $in[$i] >= $ordinate ? " # " : "   ";
        }
        say "";
    }
    say "  =" x scalar @in;
    say "  ", join "  ", @in;
    say "";
}

sub min {
    my @vals = @_;
    my $min = shift @vals;
    for my $val (@vals) {
        $min = $val if $val < $min;
    }
    return $min;
}

sub largest_rect {
    my @in = @_;
    my $largest_area = 0;
    my @best_vals = (0, 0);
    for my $i (0..$#in -1) {
        for my $j ($i + 1..$#in) {
            my $area = ($j - $i + 1) * min @in[$i..$j];
            # say "testing $i $j $area";
            if ($area > $largest_area) {
                $largest_area = $area;
                @best_vals = ($i, $j);
            }
        }
    }
    return $largest_area, @best_vals;
}

This is the displayed output for three different input data sets:

$ perl largest_rect.pl 6 5 4 2 3 1 2

  0  1  2  3  4  5  6
  -  -  -  -  -  -  -
6 #
5 #  #
4 #  #  #
3 #  #  #     #
2 #  #  #  #  #     #
1 #  #  #  #  #  #  #
  =  =  =  =  =  =  =
  6  5  4  2  3  1  2

Largest rectangle is 0 2 with an area of 12.

$ perl largest_rect.pl 6 5 4 2 3 2 2

  0  1  2  3  4  5  6
  -  -  -  -  -  -  -
6 #
5 #  #
4 #  #  #
3 #  #  #     #
2 #  #  #  #  #  #  #
1 #  #  #  #  #  #  #
  =  =  =  =  =  =  =
  6  5  4  2  3  2  2

Largest rectangle is 0 6 with an area of 14.

$ perl largest_rect.pl

  0  1  2  3  4  5
  -  -  -  -  -  -
7                #
6                #
5          #     #
4       #  #     #
3       #  #  #  #
2 #     #  #  #  #
1 #  #  #  #  #  #
  =  =  =  =  =  =
  2  1  4  5  3  7

Largest rectangle is 2 5 with an area of 12.

Largest Rectangle Histogram in Gembase

Never heard about the Gembase programming language? I’m not surprised.

Gembase is a proprietary language originally developed in the 1980s and 1990s for accessing relational databases (Digital RDB, RMS on VMS, MS SQL Server, Sybase, and Oracle under Unix or Linux), developed initially by Ross Systems and then by CDC Software. It is quite similar in many respects to PL-SQL under Oracle. It is highly efficient for large databases, and it is very powerful and expressive in terms of database access and updates, report producing, ASCII menus, and so on. But, just as PL-SQL, it is quite poor as a general purpose programming languages.

Among its limitations and other low-expressive features, I can cite:

  • The while loop is the only looping construct, no for loops, no next statement, no last statement, etc.; this leads to quite a bit of boiler-plate code to manage the loop variables;
  • no hash or associative table (well, there are virtual tables, which are pretty rich and expressive, but not with the performance of hashes);
  • No regexes;
  • Arrays are global variables and cannot be passed as a parameter to a function (although individual array elements can); also, there is no way to populate an array directly with a list of values (except with the csv_split built-in function used in the script below; in that case, the array has a 1-based index);
  • The overall syntax looks a bit obsolete (Pascal-like).

Clearly, I would not seriously use Gembase for solving such a problem (just as I would not use PL-SQL), as this leads to a lot of boring code. Raku and Perl are far far better. I undertook this task for the sole purpose of the challenge.

I guess that most people will be able to understand the overall syntax, you just need to know a few unusual things:

  • Comments are introduced by the ! exclamation mark symbol;

  • Variable names start with a sigil, namely the # symbol;

  • The language is generally not case-sensitive, it is quite common to use upper case for PROCEDURE_FORM and END_FORM to make the program structure more visible; some people also use uppercase for keywords (while, ìf, etc.), but that tends to make the code less legible, because we end up with too many uppercase words;

  • Subroutine parameters are essentially passed by reference (meaning that any parameter modification within a subroutine will be propagated on the caller’s side);

  • & is the string concatenation operator and also the code line continuation operator, so that you can use && if you want to assign a string over two code lines;

  • error /text_only is a statement used here to print out a string to the screen with a cleaner result than the ordinary print function.

This is the Gembase code:

PROCEDURE_FORM MAIN (#p1)
    #array(0) = 0
    if (#p1 = "") #p1 = "2,1,4,5,3,7"
    ! Splits the input CSV into an #array of #count values (1-based index).
    ! Arrays are global variables and cannot be passed as function parameters
    #count = csv_split(#array, #p1)
    #largest = 0
    #best_i = 0
    #best_j = 0
    perform LARGEST_RECT(#count, #largest, #best_i, #best_j)
    #msg = "Largest rectangle is between indices " & #best_i - 1 & " and " & #best_j - 1 &&
            ". Area is " & #largest & "."
    error /text_only  (#msg)
    perform DRAW_HISTO (#count)  
END_FORM

PROCEDURE_FORM LARGEST_RECT (#nb_items, #largest_area, #best_i, #best_j)
    #i = 1
    while (#i < #nb_items)
        #j = #i + 1
        while (#j <= #nb_items)
            #k = #i
            #min = #array(#k)
            ! finding the minimal height within the index range
            while (#k <= #j)
                if (#array(#k) < #min) #min = #array(#k)
                #k = #k + 1
            end_while
            #area = (#j - #i + 1) * #min
            if (#area > #largest_area)
                #largest_area = #area
                #best_i = #i
                #best_j = #j
            end_if
            #j = #j + 1
        end_while
        #i = #i + 1
end_while
END_FORM

PROCEDURE_FORM DRAW_HISTO (#nb_items)
    #i = 1
    #max_val = #array(#i)
    while (#i <= #nb_items)
        if (#array(#i) > #max_val) #max_val = #array(#i)
        #i = #i + 1
    end_while
    #i = 1
    #line = ""
    while (#i <= #nb_items)
        #line = #line & "  " & #array(#i)
        #i = #i + 1
    end_while
    error /text_only  #line
    #i = 1
    #line = ""
    while (#i <= #nb_items)
        #line = #line & "  -"
        #i = #i + 1
    end_while
    error /text_only  #line
    #ordinate = #max_val
    while (#ordinate >= 1)
        #line = #ordinate
        #i = 1
        while (#i <= #nb_items)
            if (#array(#i) >= #ordinate)
                #line = #line & " # "
            else
                #line = #line & "   "
            end_if
            #i = #i + 1
        end_while
        error /text_only  #line
        #ordinate = #ordinate - 1
    end_while
    #line = ""
    #i = 1
    while (#i <= #nb_items) 
        #line = #line & "  ="
        #i = #i + 1
    end_while
    error /text_only  #line
    #line = ""
    #i = 1
    while (#i <= #nb_items)
        #line = #line & "  " & #array(#i)
        #i = #i + 1
    end_while
    error /text_only  #line
END_FORM

This is the output of this program:

Largest rectangle is between indices 2 and 5. Area is 12.

  2  1  4  5  3  7
  -  -  -  -  -  -
7                #
6                #
5          #     #
4       #  #     #
3       #  #  #  #
2 #     #  #  #  #
1 #  #  #  #  #  #
  =  =  =  =  =  =
  2  1  4  5  3  7

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, September 6, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 74: Majority Element and FNR Character

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

Spoiler Alert: This weekly challenge deadline is due in a few hours from now. 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: Majority Element

You are given an array of integers of size $N.

Write a script to find the majority element. If none found then print -1.

Majority element in the list is the one that appears more than floor(size_of_list/2).

Example 1: Input: @A = (1, 2, 2, 3, 2, 4, 2) Output: 2, as 2 appears 4 times in the list which is more than floor(7/2).

Example 2: Input: @A = (1, 3, 1, 2, 4, 5) Output: -1 as none of the elements appears more than floor(6/2).

Majority Element in Raku

For each list, we need to go through it to count the number of occurrences of each item. We will use a bag to store the histogram of the list, and the max built-in routine to find the most common element in the list. To find the “floor” of half the number of elements, we simply use the div integer division operator.

use v6;

my @A = 1, 2, 7, 7, 7, 2, 3, 2, 4, 2, 7, 7, 7, 8, 1;
my @B = 1, 7, 7, 7, 8, 1, 7, 7, 7;
for (@A, @B) -> $c {
    my Bag $b = $c.Bag;
    my $item = $b.kv.max({$b{$_}});
    my $count = $b{$item};
    say "Majority element for $c:";
    say $count > $c.elems div 2 ?? $item !! -1;
}

This is the output for the two lists of the script:

$ raku majority.raku
Majority element for 1 2 7 7 7 2 3 2 4 2 7 7 7 8 1:
-1
Majority element for 1 7 7 7 8 1 7 7 7:
7

Majority Element in Perl

Perl doesn’t have a Bag data type, but we can simply use a hash to store the histogram of input values. Also, Perl doesn’t have a max built-in, so we’ll implement it manually. Also note that the floor in the specification is kind of a red herring: it is just useless if the number of items in the list is even, and it is also not needed if the number of items is odd, since we can just compare the decimal value to the number of matching items.

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

my @A = (1, 2, 2, 3, 2, 4, 2, 7, 8, 9, 10);
my %histogram;
$histogram{$_}++ for @A;
my $max = 0;
for my $key (keys %histogram) {
    $max = $key unless $max;
    $max = $key if $histogram{$key} > $histogram{$max};
}
say $histogram{$max} > ( @A / 2) ? $max : -1;

With the list coded in the script the result is as expected:

$ perl majority.pl
-1

Task 2: FNR Character

You are given a string $S.

Write a script to print the series of first non-repeating character (left -> right) for the given string. Print # if none found.

Example 1:

Input: $S = ‘ababc’
Output: ‘abb#c’
Pass 1: “a”, the FNR character is ‘a’
Pass 2: “ab”, the FNR character is ‘b’
Pass 3: “aba”, the FNR character is ‘b’
Pass 4: “abab”, no FNR found, hence ‘#’
Pass 5: “ababc” the FNR character is ‘c’

Example 2:

Input: $S = ‘xyzzyx’
Output: ‘xyzyx#’
Pass 1: “x”, the FNR character is “x”
Pass 2: “xy”, the FNR character is “y”
Pass 3: “xyz”, the FNR character is “z”
Pass 4: “xyzz”, the FNR character is “y”
Pass 5: “xyzzy”, the FNR character is “x”
Pass 6: “xyzzyx”, no FNR found, hence ‘#’

Sorry: either I miss something, or the first non-repeating character is ill defined. Taking example 1, b is selected at pass 2 and 3. Admittedly, b is not yet repeating at pass 3. But, then, the FNR character at pass 2 should be a. Since I cannot really make sense of the examples provided, I’ll use my own interpretation of the FNR rules, rather that following my initial intention to simply skip the task. At least, Mohammad will not miss his targeted third 100 responses in a row because of me.

FNR Character in Raku

I know this is not what Mohammad Anwar is expecting, but, as I said, I made my own rules:

use v6;

# Note: IMHO, FNR is ill-defined. I'll use my own rules.
my $S = 'ababcbaddccaad';
my @chars = $S.comb;
my $result = "";
my %seen;
for (@chars) {
    my $fnr = "#";
    for @chars -> $char {
        $fnr = $char and last unless %seen{$char};
        $fnr = $char and last if %seen{$char} < 2;
    }
    $result ~= $fnr;
    %seen{$_}++;
}
say $result;

Result:

$ raku non-repeating.raku
aaabcccccc####

FNR Character in Perl

Same comment as before: I know this is not what Mohammad Anwar is expecting, but I made my own rules:

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

# Note: IMHO, FNR is ill-defined. I'll use my own rules.
my $S = 'ababcbad';
my @chars = split //, $S;
my $result = "";
my %seen;
for (@chars) {
    my $fnr = "#";
    for my $char (@chars) {
        $fnr = $char and last unless $seen{$char};
        $fnr = $char and last if $seen{$char} < 2;
    }
    $result .= $fnr;
    $seen{$_} ++;
}
say $result;

Result:

$ perl non-repeating.pl
aaabcccccc####

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, August 30, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 73: Min Sliding Window and Smallest Neighbor

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on Aug. 16, 2020). 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: Min Sliding Window

You are given an array of integers @A and sliding window size $S.

Write a script to create an array of min from each sliding window.

Example:

Input: @A = (1, 5, 0, 2, 9, 3, 7, 6, 4, 8) and $S = 3
Output: (0, 0, 0, 2, 3, 3, 4, 4)

[(1 5 0) 2 9 3 7 6 4 8] = Min (0)
[1 (5 0 2) 9 3 7 6 4 8] = Min (0)
[1 5 (0 2 9) 3 7 6 4 8] = Min (0)
[1 5 0 (2 9 3) 7 6 4 8] = Min (2)
[1 5 0 2 (9 3 7) 6 4 8] = Min (3)
[1 5 0 2 9 (3 7 6) 4 8] = Min (3)
[1 5 0 2 9 3 (7 6 4) 8] = Min (4)
[1 5 0 2 9 3 7 (6 4 8)] = Min (4)

Min Sliding Window in Raku

Not very much to comment. I’ve decided pass the size of the sliding window as an argument to the program (with a value defaulted to 3 if no argument is passed). Raku has a built-in min function which we can use on every sliding window. Otherwise, this task is a nice opportunity to use the gather ... take construct

use v6;

my @a = 1, 5, 0, 2, 9, 3, 7, 6, 4, 8;
my $s =  @*ARGS[0] // 3;

my @result = gather {
    for 0..@a.elems - $s  -> $i {
        take min @a[$i..^$i + $s];
    }
}
say @result;

This script duly outputs the correct result with the default value (3):

$ raku sliding.raku
[0 0 0 2 3 3 4 4]

The result is also fine when passing a parameter (5):

$ raku sliding.raku 5
[0 0 0 2 3 3]

Min Sliding Window in Perl

Perl doesn’t have a built-in min function. We would obviously use the min subroutine provided by the List::Util module, but, as usual, for a coding challenge, I don’t want to use a ready-made solution and prefer to show how this can be done “by hand” in pure Perl. Besides that, the program is quite similar to the Raku program, except that I replaced the use of the gather ... take construct by a simple push into the previously declared @result array:

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

sub min {
    my $min = shift;
    for (@_) {
        $min = $_ if $_ < $min;
    }
    $min;
}

my @a = (1, 5, 0, 2, 9, 3, 7, 6, 4, 8);
my $s =  shift // 3;
my @result;
for my $i (0..@a - $s) {
    push @result, min @a[$i..$i + $s - 1];
}
say "@result";

This displays the correct results:

$ perl sliding.pl
0 0 0 2 3 3 4 4

$ perl sliding.pl 5
0 0 0 2 3 3

Task #2: Smallest Neighbor

You are given an array of integers @A.

Write a script to create an array that represents the smallest element to the left of each corresponding index. If none found then use 0.

Example 1:

Input: @A = (7, 8, 3, 12, 10)
Output: (0, 7, 0, 3, 3)

For index 0, the smallest number to the left of $A[0] i.e. 7 is none, so we put 0.
For index 1, the smallest number to the left of $A[1] as compare to 8, in (7) is 7 so we put 7.
For index 2, the smallest number to the left of $A[2] as compare to 3, in (7, 8) is none, so we put 0.
For index 3, the smallest number to the left of $A[3] as compare to 12, in (7, 8, 3) is 3, so we put 3.
For index 4, the smallest number to the left of $A[4] as compare to 10, in (7, 8, 3, 12) is 3, so we put 3 again.

Example 2:

Input: @A = (4, 6, 5)
Output: (0, 4, 4)

For index 0, the smallest number to the left of $A[0] is none, so we put 0.
For index 1, the smallest number to the left of $A[1] as compare to 6, in (4) is 4, so we put 4.
For index 2, the smallest number to the left of $A[2] as compare to 5, in (4, 6) is 4, so we put 4 again.

Note that what we are supposed to do is not clear when the smallest element to the left is equal to the current element. I’ll consider that the smallest element to the left has to be strictly less than the current element. Choosing the other interpretation would be a minor change to the code anyway.

Smallest Neighbor in Raku

I don’t want to recompute every time the minimum element of an ever-increasing list, so I prefer to maintain a $min variable to keep track of the smallest item seen so far during the loop overt the input array. Also, rather than having to deal with an edge case for the first element, I decided to pre-populate the @result array with 0 (the first item of the resulting list is always bound to be 0), to assign the first input item to $min and t remove it from the input array.

use v6;

my @a = 7, 8, 3, 12, 10;
my @result = 0,;
my $min = shift @a;
for @a -> $item {
    if $item < $min {
        push @result, 0;
        $min = $item;
    } else {
        push @result, $min;
    }
}
say @result;

This displays the following output:

$ raku smallest_n.raku
[0 7 0 3 3]

Smallest Neighbor in Perl

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

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

my @a = (7, 8, 3, 12, 10);
my @result = (0);
my $min = shift @a;
for my $item (@a) {
    if ($item < $min) {
        push @result, 0;
        $min = $item;
    } else {
        push @result, $min;
    }
}
say "@result";

This displays the following output:

$ perl smallest_n.pl
0 7 0 3 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, August 23, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 72: One-Liners for Trailing Zeros and Line Ranges

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

Spoiler Alert: This weekly challenge deadline is due in a few hours. This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Since both tasks in this week challenge are quite simple, I decided to use only one-liners to solve each task, both in Raku and in Perl.

Task 1: Trailing Zeros

You are given a positive integer $N (<= 10).

Write a script to print number of trailing zeroes in $N!.

Example 1:

Input: $N = 10
Output: 2 as $N! = 3628800 has 2 trailing zeroes

Example 2

Input: $N = 7
Output: 1 as $N! = 5040 has 1 trailing zero

Example 3:

Input: $N = 4
Output: 0 as $N! = 24 has 0 trailing zero

Trailing Zeroes in Raku

We start with actually computing $N! and counting the number of trailing zeros:

$ raku -e 'my $f = [*] 1.. @*ARGS[0]; say $f ~~ /(0+$)/ ??  $0.Str.chars !! 0;' 10
2

$ raku -e 'my $f = [*] 1.. @*ARGS[0]; say $f ~~ /(0+$)/ ??  $0.Str.chars !! 0;' 7
1

$ raku -e 'my $f = [*] 1.. @*ARGS[0]; say $f ~~ /(0+$)/ ??  $0.Str.chars !! 0;' 4
0

But it is a bit silly to compute $N!: to find the number of trailing zeros, we only need to find the number of fives in the prime factors of the list of numbers that get multiplied in the factorial product. And since we know that the input integer is less than or equal to 10, we only need to take the integer part of the division of the input number by 5 (that works well until 24 and breaks at 25 because of the two fives in the prime factors of 25):

$ raku -e 'say  (@*ARGS[0] / 5).Int;' 10
2

$ raku -e 'say  (@*ARGS[0] / 5).Int;' 7
1

$ raku -e 'say  (@*ARGS[0] / 5).Int;' 4
0

We could also use the integer division operator. But that doesn’t work as I would hope:

$ raku -e 'say  @*ARGS[0] div 5;' 10
Cannot resolve caller infix:<div>(Str:D, Int:D); none of these signatures match:
    (Int:D \a, Int:D \b --> Int:D)
    (int $a, int $b --> int)
  in block <unit> at -e line 1

Unfortunately, Raku doesn’t recognize the argument (10) as an integer, but “thinks” it is a string. To me, this is a bug: in my view, the program should be able to recognize an integer. It is of course quite easy to solve the problem by coercing the argument to an integer::

$ raku -e 'say  @*ARGS[0].Int div 5;' 10
2

Trailing Zeroes in Perl

We’ve seen in the Raku section above that, up to 24, we can just divide the argument by 5 (and the task specification says that the input argument should be less or equal to 10). So porting the second Raku one-liner to Perl is quite simple:

$ perl -E 'say int shift()/5;' 10
2

$ perl -E 'say int shift()/5;' 7
1

$ perl -E 'say int shift()/5;' 4
0

Task2: Line Ranges

You are given a text file name and range $A - $B where $A <= $B.

Write a script to display lines range $A and $B in the given file.

Example input:

$ cat input.txt
L1
L2
L3
L4
...
...
...
...
L100

$A = 4 and $B = 12

Output:

L4
L5
L6
L7
L8
L9
L10
L11
L12

Since this blog post is about Raku and Perl one-liners, let’s start with populating the input file with a one-liner. This can be done as follows in Raku:

$ raku -e 'say "L$_" for 1..100' > input.txt

Or with exactly the same one-liner in Perl:

$ perl -E 'say "L$_" for 1..100' > input.txt

Both produce the desired input file:

$ cat input.txt
L1
L2
L3
(Lines omitted for brevity)
L98
L99
L100

Line Ranges in Raku

We just read the file and print the lines when the line number is within the range. Note that using IO.lines.kv, line numbers start at 0; therefore, we need to shift the value by 1 to get the proper result.

$ raku -e 'sub MAIN (Int $a, Int $b where * > $a) {for "input.txt".IO.lines.kv -> $i, $j {$j.say if $b > $i >= $a-1}}' 7 10
L7
L8
L9
L10

We can make the one-liner script slightly shorter by removing the pointy block and using self-declared variables instead:

$ raku -e 'sub MAIN (Int $a, Int $b where * > $a) {for "input.txt".IO.lines.kv { $^d.say if $b > $^c >= $a-1}}' 7 10
L7
L8
L9
L10

I was hoping to use the ff flip-flop operator, but that did not lead to simpler code (contrary to Perl, as shown below).

Line Ranges in Perl

There ought to be a few things for which Perl is better than Raku. This seems to be the case for this task, where the .. flip-flop operator does all the work for us:

$ perl -ne 'print if 7..10' input.txt
L7
L8
L9
L10

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, August 16, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 71: Peak Elements and Trim Linked List

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

Task 1: Peak Elements

You are given positive integer $N (>1).

Write a script to create an array of size $N with random unique elements between 1 and 50.

In the end it should print peak elements in the array, if found.

An array element is called peak if it is bigger than it’s neighbour.

Example 1:

Array: [ 18, 45, 38, 25, 10, 7, 21, 6, 28, 48 ]
Peak: [ 48, 45, 21 ]

Example 2:

Array: [ 47, 11, 32, 8, 1, 9, 39, 14, 36, 23 ]
Peak: [ 47, 32, 39, 36 ]

The specification somewhat lacks precision, but the examples are clear enough to clarify.

Peak Elements in Raku

In Raku, the pick built-in method provides (pseudo-)random unique elements from a list or a range. It is then just a matter of comparing each item with its predecessor and its successor, and to add the first item of the list if it is larger than the second one, and the last item if it is larger than the one before the last.

use v6;

sub MAIN (Int $n where 1 < * <= 50) {
    my @nums = (1..50).pick: $n;
    say @nums;
    my @peaks = gather {
        for 1..^@nums.end -> $i {
            take @nums[$i] if @nums[$i-1] < @nums[$i] > @nums[$i+1];
        }
    }
    unshift @peaks, @nums[0] if @nums[1] < @nums[0];
    push @peaks, @nums[@nums.end] 
        if @nums[@nums.end] > @nums[@nums.end -1];
    say @peaks;
}

These are a few sample runs of this program:

$ raku peak.raku 10
[33 35 4 20 2 16 7 31 23 46]
[35 20 16 31 46]
-
$ raku peak.raku 10
[32 34 30 48 14 50 17 12 26 5]
[34 48 50 26]
-
$ raku peak.raku 10
[15 4 31 49 16 14 23 5 26 17]
[15 49 23 26]
-
$ raku peak.raku 10
[4 40 28 46 43 33 49 1 15 18]
[40 46 49 18]
-
$ raku peak.raku 40
[19 12 30 46 27 15 14 41 43 3 17 32 48 10 18 24 26 37 33 28 35 40 22 9 23 39 29 8 47 1 2 49 34 42 44 16 4 38 21 31]
[19 46 43 48 37 40 39 47 49 44 38 31]
-
$ raku peak.raku 40
[40 10 7 32 44 5 4 29 16 49 30 28 38 35 46 45 11 6 47 8 26 18 34 13 23 19 50 12 43 37 25 17 33 31 42 36 9 15 39 2]
[40 44 29 49 38 46 47 26 34 23 50 43 33 42 39]
-
$ raku peak.raku 45
[47 8 31 46 35 19 17 23 43 41 7 6 24 45 34 3 32 2 22 18 29 26 42 40 49 48 13 11 44 30 12 4 9 20 21 10 15 36 50 14 39 33 1 5 27]
[47 46 43 45 32 22 29 42 49 44 21 50 39 27]

Peak Elements in Perl

Perl doesn’t have a built-in pick function to provide random unique elements from a list or a range. The Perl rand function returns a (pseudo)-random fractional number greater than or equal to 0 and less than the value of the parameter passed to it. So, to get a random integer between 1 and 50, we need something like this:

my $element = int(rand(50) + 1);

To ensure that the random numbers are unique, we use the %unique hash which enables us to remove any duplicate from the list.

The rest of the program is essentially a port to Perl of the Raku program: we loop through the list of random integers and keep those which are larger than their predecessors and successors, and we add the first item of the list if it is larger than the second one, and the last item if it is larger than its predecessor.

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

my $n = shift;
my %unique;
my @items;
while (%unique < $n) {
    my $element = int(rand(50) + 1);
    push @items, $element unless exists $unique{$element};
    $unique{$element} = 1
}

say "Original list: @items";
my @peaks;
push @peaks, $items[0] if $items[0] > $items[1];
for my $i (1..$#items - 1) {
    push @peaks, $items[$i] if $items[$i] > $items[$i-1] 
        and $items[$i] > $items[$i+1];
}
push @peaks, $items[-1] if $items[-1] > $items[-2];
say "Peaks: @peaks";

This is the output of a few sample runs:

$ perl peak.pl 10
Original list: 14 11 23 37 17 20 40 47 29 7
Peaks: 14 37 47

$ perl peak.pl 10
Original list: 43 48 28 35 8 36 11 39 4 29
Peaks: 48 35 36 39 29

$ perl peak.pl 20
Original list: 20 4 30 25 1 2 41 39 24 17 3 44 29 49 8 34 13 28 12 38
Peaks: 20 30 41 44 49 34 28 38

$ perl peak.pl 3
Original list: 10 23 12
Peaks: 23

$ perl peak.pl 49
Original list: 13 32 24 40 28 34 39 15 43 29 42 5 6 46 9 27 12 3 33 30 2 23 11 48 17 20 10 8 50 4 45 36 26 37 1 41 21 35 31 18 16 49 44 19 14 7 47 25 38
Peaks: 32 40 39 43 42 46 27 33 23 48 20 50 45 37 41 35 49 47 38

Task 2: Trim Linked List

You are given a singly linked list and a positive integer $N (>0).

Write a script to remove the $Nth node from the end of the linked list and print the linked list.

If $N is greater than the size of the linked list then remove the first node of the list.

NOTE: Please use pure linked list implementation.

Example:

Given Linked List: 1 -> 2 -> 3 -> 4 -> 5
when $N = 1
Output: 1 -> 2 -> 3 -> 4
when $N = 2
Output: 1 -> 2 -> 3 -> 5
when $N = 3
Output: 1 -> 2 -> 4 -> 5
when $N = 4
Output: 1 -> 3 -> 4 -> 5
when $N = 5
Output: 2 -> 3 -> 4 -> 5
when $N = 6
Output: 2 -> 3 -> 4 -> 5

I don’t know why Mohammad keeps suggesting challenges with linked lists, which are essentially useless both in Perl and in Raku: both languages have dynamic arrays which offer essentially all the services offered by linked lists in lower-level languages such as C. In fact, except possibly for pedagogical purpose, I strongly object to the very idea of implementing linked lists in Perl or in Raku.

So, I’ll implement a pure linked list implementation in Raku, since this is part of the specification, using an object oriented design, but I’ll willfully cheat and use built-in arrays for the details, because this is my view the right way to remove an item from a collection.

My program implements a Node class defining a simple node structure (with a value and a link to the next node), and a Linkedlist class holding the head of the linked list and defining a make-array method to transform the linked list into an array. There is also a gist method to provide a string representation of the linked list (the overloaded gist method is used by the say routine). The code also has a build-linked-list subroutine to transform an array into a linked list. The idea of the program is to transform a linked list into an array, to remove the desired item from the array, and to convert the array back into a new linked list.

use v6;

class Node {
    has $.value is rw;
    has $.next is rw;
}
class Linkedlist {
    has Node $.head;
    method make-array () {
        my $node = $.head;
        my @array = $node.value;
        while $node.next:defined {
            $node = $node.next;
            push @array, $node.value;
        }
    return @array;
    }
  method gist () {
        my @a = | $.make-array;
        return join ' -> ', @a;
    }
}
sub build-linked-list (@values is copy) {
    my $last = @values[*-1];
    my @nodes;
    my $tail = Node.new( value => $last, next => Nil);
    @nodes[$last] = $tail;
    for @values[1..@values.end].keys.reverse -> $i {
        my $node = Node.new( value => @values[$i], 
            next => @nodes[@values[$i+1]]);
        @nodes[@values[$i]] = $node;
    }
    return Linkedlist.new( head => @nodes[@values[0]]);
}

sub MAIN (Int $n) {
    my @start_range = 1..5;
    my $linked_list = build-linked-list @start_range;
    say "Original list: ", $linked_list;
    my @a = $linked_list.make-array;
    my @new_range = @start_range;
    if $n >= @a.elems {
        shift @new_range;
    } else {
        @new_range[@new_range.end - $n +1]:delete;
    }
    @new_range = grep {.defined }, @new_range;
    my $next_linked_list = build-linked-list @new_range;
    say "New linked list: ", $next_linked_list;
}

This is the output for a few test cases:

$ raku linked_list.raku 7
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 2 -> 3 -> 4 -> 5

$ raku linked_list.raku 3
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 4 -> 5

$ raku linked_list.raku 1
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 3 -> 4

$ raku linked_list.raku 2
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 3 -> 5

$ raku linked_list.raku 5
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 2 -> 3 -> 4 -> 5

As said earlier, I don’t think it is right to implement linked lists in Raku or Perl. I nonetheless did it in Raku to show my good will. But I still think this is a deadly wrong idea. Therefore, I will decline to answer the task in Perl (I have shown in earlier challenges that I know how to do it if needed, it is really the fact that I object to it that leads me to that decision).

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, August 9, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.