Perl Weekly Challenge 78: Leader Element and Left Rotation

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

Spoiler Alert: This weekly challenge deadline is due in a few days (September 20, 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: Leader Element

You are given an array @A containing distinct integers.

Write a script to find all leader elements in the array @A. Print (0) if none found.

An element is leader if it is greater than all the elements to its right side.

Example 1:

Input: @A = (9, 10, 7, 5, 6, 1)
Output: (10, 7, 6, 1)

Example 2:

Input: @A = (3, 4, 5)
Output: (5)

Two small comments. First, if we set aside the (very special) case where the input array is empty, we will never have to print 0, since the last item of the array will always be a leader element. Second, I’ll interpret the leader element definition as strictly greater than all its successors.

Leader Element in Raku

We only need to read the input array backward and keep track of the maximum element seen so far. Any item strictly greater than all items seen previously is a leader. Here, we do it for the two arrays provided as examples.

use v6;

my @in = [9, 10, 7, 5, 6, 1], [3, 4, 5];
for @in -> @a {
    my @result = gather {
        my $max = @a[*-1];
        take $max;
        for @a.reverse -> $item {
            if $item > $max {
                take $item;
                $max = $item;
            }
        }
    }
    say "Input: @a[]; Output: ", @result.reverse;
}

The result is in conformity with what we expected:

Input: 9 10 7 5 6 1; Output: (10 7 6 1)
Input: 3 4 5; Output: (5)

Leader Element in Perl

Just like in Raku, we read the input array backward and keep track of the maximum element seen so far. Any item strictly greater than all items seen previously is a leader.

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

my @in = ([9, 10, 7, 5, 6, 1], [3, 4, 5]);
for my $aref (@in) {
    my @result;
    my $max = @$aref[-1];
    push @result, $max;
    for my $item (reverse @$aref) {
        if ($item > $max) {
            push @result, $item;
            $max = $item;
        }
    }
    say "Input: @$aref; Output: ", join " ", reverse @result;
}

Here again, the result is what we expected:

$ perl leader.pl
Input: 9 10 7 5 6 1; Output: 10 7 6 1
Input: 3 4 5; Output: 5

Left Rotation

You are given array @A containing positive numbers and @B containing one or more indices from the array @A.

Write a script to left rotate @A so that the number at the first index of @B becomes the first element in the array. Similarly, left rotate @A again so that the number at the second index of @B becomes the first element in the array.

Example:

Input:
    @A = (10 20 30 40 50)
    @B = (3 4)

Explanation:

a) We left rotate the 3rd index element (40) in the @A to make it 0th index member in the array.
        [40 50 10 20 30]

b) We left rotate the 4th index element (50) in the @A to make it 0th index member in the array.
        [50 10 20 30 40]

Output:
    [40 50 10 20 30]
    [50 10 20 30 40]

Left Rotation in Raku

We can simply use array slices to get what we need. The only slight difficulty is that we need to flatten the two index slices into a single list.

use v6;

my @a = 10, 20, 30, 40, 50;
my @indices = 3, 4;

say "Input array: ", @a;
for @indices -> $i {
    my @out = @a[($i..@a.end, 0..$i -1).flat];
    say @out;
}

Output:

$ raku left_rotate.raku
Input array: [10 20 30 40 50]
[40 50 10 20 30]
[50 10 20 30 40]

Left Rotation in Perl

Again, we use array slices. Here, the only slight difficulty is the relatively heavy use of nested array references.

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

my @a = ( [[10, 20, 30, 40, 50],[3, 4]], 
          [[7, 4, 2, 6, 3], [1, 3, 4]] );
left_rotate($_) for @a;

sub left_rotate {
    my $inref = shift;
    my ($in, $indices) = @$inref;
    say "\nInput array: @$in - Indices: @$indices";
        for my $i (@$indices){
        my @out = @$in[$i..$#{$in}, 0..$i -1];
        say "@out";
    }
}

Output:

$ perl left_rotate.pl

Input array: 10 20 30 40 50 - Indices: 3 4
40 50 10 20 30
50 10 20 30 40

Input array: 7 4 2 6 3 - Indices: 1 3 4
4 2 6 3 7
6 3 7 4 2
3 7 4 2 6

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

Perl Weekly Challenge: Fibonacci Sum and Lonely X

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (September 13, 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: Fibonacci Sum

You are given a positive integer $N.

Write a script to find out the smallest combination of Fibonacci Numbers required to get $N on addition.

You are NOT allowed to repeat a number. Print 0 if none found.

Example 1:

Input: $N = 6
Output:
    1 + 5 = 6

Example 2:

Input: $N = 9
Output:
    1 + 8 = 9

My first comment is that we will never have to print 0: any strictly positive integer can be expressed as a sum of some Fibonacci numbers with no duplicates. This can be proven rigorously, but since this a not a math challenge, I will only give a gist of a demonstration with a numeric example. Consider any input integer, say 30, and all Fibonacci numbers less than 30:

1 2 3 5 8 13 21

We can subtract the largest Fibonacci number less than or equal to 30, i.e. 21, and get 9. We can repeat the operation with the new number, 9, subtract 8 from it and get 1. We repeat once more and get 0. Thus, 30 is the sum of the following Fibonacci numbers: [21 8 1]. Since the ratio between two consecutive Fibonacci numbers tends toward 1.618 (more precisely towards the golden mean, whose precise value is square root of 5 + 1 divided by 2), the iterative process will either stop early when the difference found is a Fibonacci number, or will converge very rapidly toward the smallest Fibonacci numbers. It can easily be shown that, with such a process, it is never possible to get a duplicate Fibonacci numbers. It is also not difficult to see that, since we always pick with the largest possible Fibonacci number, this process is bound to lead the smallest collection of Fibonacci numbers whose sum is equal to the input target.

Note: The task was changed after having been published and now requires “to find out all possible combination of Fibonacci Numbers required to get $N on addition.” I discovered this change after having completed the task in both Raku and Perl. That’s too late, I will show solutions to the original task, especially in view of the fact that the modified task is in my humble opinion less interesting, as finding all combinations of a list of items matching a certain condition is very similar to a number of tasks of previous challenges.

Fibonacci Sum in Raku (Original Task)

Rather than just finding a sum of Fibonacci numbers for a single input target integer, I’ve decided to illustrate the fact that it always possible to find a sum of Fibonacci numbers to obtain a target input integer, I’ll do it for every integer between 1 and 1,000.

So, we first generate an array of Fibonacci numbers less than 1000 in descending order. Then we simply iterate over this array and subtract the value found in the array if it is less than or equal to the current value, until we reach 0.

use v6;
# Original task!

my @fib = (1, 2, -> $a, $b { $a + $b } ...^ * > 1000).reverse;
for 1..1000 -> $n {
    my $curr = $n;
    my @result;
    for @fib -> $i {
        next if $i > $curr;
        push @result, $i;
        last if $i == $curr;
        $curr -= $i;
    }
    say "$n -> ", @result;
}

This is an excerpt of the output:

1 -> [1]
2 -> [2]
3 -> [3]
4 -> [3 1]
5 -> [5]
6 -> [5 1]
7 -> [5 2]
8 -> [8]
9 -> [8 1]
10 -> [8 2]
11 -> [8 3]
12 -> [8 3 1]
13 -> [13]
14 -> [13 1]
15 -> [13 2]
16 -> [13 3]
17 -> [13 3 1]
[ Lines omitted for brevity ]
984 -> [610 233 89 34 13 5]
985 -> [610 233 89 34 13 5 1]
986 -> [610 233 89 34 13 5 2]
987 -> [987]
988 -> [987 1]
989 -> [987 2]
990 -> [987 3]
991 -> [987 3 1]
992 -> [987 5]
993 -> [987 5 1]
994 -> [987 5 2]
995 -> [987 8]
996 -> [987 8 1]
997 -> [987 8 2]
998 -> [987 8 3]
999 -> [987 8 3 1]
1000 -> [987 13]

Fibonacci Sum in Raku (Modified Task)

I said before that I originally did not intend to provide solutions to the modified task, but it is so simple in Raku that I changed my mind and will nonetheless provide a solution:

# (Modified task)
my $n = @*ARGS[0]:exists ?? @*ARGS[0] !! 30;
my @fib = 1, 2, * + *  ... ^ * >= $n;
for @fib.combinations -> $s {
    say $s if $n == [+] $s;
}

Output:

(1 8 21)
(1 3 5 21)
(1 3 5 8 13)

This can be made more concise:

my $n = @*ARGS[0]:exists ?? @*ARGS[0] !! 30;
.say if $n == $_.sum for (1, 2, * + *  ... ^ * >= $n).combinations;

This script displays the same output.

Fibonacci Sum in Perl (Original Task)

This program uses the same algorithm as the Raku program (see above), but handles only one input value instead of a full range. The only other significant difference is that the array of Fibonacci numbers is built in a while loop.

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

# Original task

my $target = shift // 100;
my @fib = (1, 2);
while (1) {
    my $new_fib = $fib[-1] + $fib[-2];
    last if $new_fib >= $target;
    push @fib, $new_fib;
}
my $curr = $target;
my @result;
for my $i (reverse @fib) {
    next if $i > $curr;
    push @result, $i;
    last if $i == $curr;
    $curr -= $i;
}
say "$target ->  @result";

Running this script using the default value:

$ perl fib.pl
100 ->  89 8 3

And using a relatively large input value:

$ perl fib.pl 100000
100000 ->  75025 17711 6765 377 89 21 8 3 1

Task 2: Lonely X

You are given m x n character matrix consists of O and X only.

Write a script to count the total number of X surrounded by O only. Print 0 if none found.

Example 1:

Input: [ O O X ]
       [ X O O ]
       [ X O O ]

Output: 1 as there is only one X at the first row last column surrounded by only O.

Example 2:

Input: [ O O X O ]
       [ X O O O ]
       [ X O O X ]
       [ O X O O ]

Output: 2

    a) First  X found at Row 1 Col 3.

    b) Second X found at Row 3 Col 4.

Lonely X in Raku

We traverse the matrix and call the check subroutine when the visited item is a 'X'. The check subroutine verifies whether any neighbor of the visited item is a 'X'. The only slight difficulty is the special cases where some of the neighbors might not be defined.

use v6;

my @matrix = [ <O O X O> ],
             [ <X O O O> ],
             [ <X O O X> ],
             [ <O X O O> ];

# @matrix = [ 0, 0, 'X'], [ 'X', 0, 0], [ 'X', 0, 0 ];

# @matrix = [<X X X>], [0, 0, 0];

sub check (Int $m, Int $k) {
    for -1, 0, 1 -> $i {
        for -1, 0, 1 ->$j {
            next if $i == 0 and $j == 0;  # the item being verified, bound to be an 'X'
            next if $m+$i < 0 or $k+$j < 0; # out of the matrix
            next unless defined @matrix[$m+$i] and defined @matrix[$m+$i][$k+$j];
            return False if @matrix[$m+$i][$k+$j] eq 'X';
        }
    }
    return True;
}

my @result;
for 0..@matrix[0].end -> $j {
    for 0..@matrix.end -> $i {
        next unless @matrix[$i][$j] eq 'X';
        push @result, [$i, $j] if check $i, $j;
    }
}
say @result.elems > 0 ?? @result !! 0;

Output:

$ raku lonely.raku
[[0 2] [2 3]]

Lonely X in Perl

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

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

my @matrix = ([ 0, 0, 'X'], [ 'X', 0, 0], [ 'X', 0, 0 ]);

@matrix = ([ qw<O O X O> ],
          [ qw<X O O O> ],
          [ qw<X O O X> ],
          [ qw<O X O O> ]);

# @matrix = ([qw <X X X>], [0, 0, 0]);

sub check {
    my ($m, $k) = @_;
    for my $i (-1, 0, 1) {
        for my $j (-1, 0, 1) {
            next if $i == 0 and $j == 0;
            next if $m+$i < 0 or $k+$j < 0;
            next unless exists $matrix[$m+$i] and exists $matrix[$m+$i][$k+$j];
            return 0 if $matrix[$m+$i][$k+$j] eq 'X';
        }
    }
    return 1;
}

my @result;
for my $i (0..$#{$matrix[0]}) {
    for my $j (0..$#matrix) {
        next unless $matrix[$j][$i] eq 'X';
        push @result, [$j, $i] if check $j, $i;
    }
}
say "@$_" for  @result;
say 0 unless @result;

Output:

$ perl lonely.pl
0 2
2 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, September 20, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 76: Letter Grid

These are some answers to the Week 76 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: Prime Sum

I’ve written a Raku program to solve this task, but it is unfortunately a bit buggy: it works in most cases, but there are a few rare cases where it doesn’t find the minimum number of prime numbers whose summation gives you the target number. I certainly don’t want to publish here a program which I know to be faulty in some cases, and I no longer have time before the deadline to fix it. So, I’ll skip this task for now.

Task #2: Word Search

Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.

Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.

Search Grid:

B I D E M I A T S U C C O R S T
L D E G G I W Q H O D E E H D P
U S E I R U B U T E A S L A G U
N G N I Z I L A I C O S C N U D
T G M I D S T S A R A R E I F G
S R E N M D C H A S I V E E L I
S C S H A E U E B R O A D M T E
H W O V L P E D D L A I U L S S
R Y O N L A S F C S T A O G O T
I G U S S R R U G O V A R Y O C
N R G P A T N A N G I L A M O O
E I H A C E I V I R U S E S E D
S E T S U D T T G A R L I C N H
H V R M X L W I U M S N S O T B
A E A O F I L C H T O D C A E U
Z S C D F E C A A I I R L N R F
A R I I A N Y U T O O O U T P F
R S E C I S N A B O S C N E R A
D R S M P C U U N E L T E S I L

Output:

Found 54 words of length 5 or more when checked against the local dictionary. You may or may not get the same result but that is fine.

aimed, align, antes, argos, arose, ashed, blunt, blunts, broad, buries, clove, cloven, constitution, constitutions, croon, depart, departed, enter, filch, garlic, goats, grieve, grieves, hazard, liens, malign, malignant, malls, margo, midst, ought, ovary, parted, patna, pudgiest, quash, quashed, raped, ruses, shrine, shrines, social, socializing, spasm, spasmodic, succor, succors, theorem, theorems, traci, tracie, virus, viruses, wigged

My first reaction was to hate this task because it requires a lot of code lines (so many different cases) for a coding challenge. So, I tried to make a relatively concise solution avoiding code repetition.

Word Search in Raku

I have in my default directory a words.txt file containing about 114,000 English words. They are all lower-case words, so I’ll have to change case for the input grid. The authorized words will be stored in a Set.

The grid will be read from a file ans stored in an array or arrays.

The program reads arrays from the grid in all directions (horizontal, vertical, from top left to bottom right and from top right to bottom left and calls the find_words subroutine. This subroutine takes an array of letters as input, and looks for words, both forward and backward, in the input array.

use v6;

my ($dict, $grid-file) = @*ARGS;
my $min-length = @*ARGS[2]:exists ?? @*ARGS[2] !! 5;
my $words = $dict.IO.lines.grep({.chars >= $min-length}).Set;
my @grid;
for  $grid-file.IO.lines -> $line {
    my @letters = $line.lc.split(' ');
    push @grid, @letters;
}
my $max_row = @grid.end;
my $max_col = @grid[0].end;
my $result = SetHash.new;

sub find_words (@row) {
    for 0 .. @row.end -> $i {
        for $i+$min-length-1 .. @row.end -> $j {
            my $word = join '', @row[$i..$j];
            $result{$word}++ if $words{$word};
            my $flipped = $word.flip;
            $result{$flipped}++ if $words{$flipped};
        }
    }
}
# Horizontal
for @grid -> @row {
    find_words @row;
}
# Vertical
for 0..$max_col -> $i {
    my @col = map { @grid[$_][$i] }, 0..$max_row;
    find_words @col;
}
# Oblique, NW to SE
for 0..$max_col - $min-length + 1 -> $i {
    my @vals = grep {defined $_}, map { @grid[$_][$_+$i] }, 0..$max_row;
    find_words @vals;
}
for 1..$max_row-$min-length+1 -> $j {
    my @vals = grep {defined $_}, map { @grid[$_+$j][$_]}, 0..$max_row;
    find_words @vals;
}
# Oblique, NE to Sw
for $min-length - 1 .. $max_col -> $j {
    my @vals = grep {defined $_}, map { @grid[$j-$_][$_] }, 0..$max_col;
    find_words @vals;
}
for 1 ..$max_row - $min-length + 1 -> $i {
    my @vals = grep {defined $_}, map { @grid[$i+$_][$max_col-$_] },  0..$max_col;
    find_words @vals;
}  
say join " ", sort keys $result;

This program produces the following output with 57 words:

$ raku letter-grid.raku words.txt grid.txt
aimed align antes arose ashed blunt blunts broad buries clove cloven constitution croon depart departed duddie enter filch garlic goats grieve grieves grith hazard ileac liens lunts malign malignant malls midst midsts ought ovary parted pudgiest quash quashed raias raped roser ruses shrine shrines sices social socializing soyas spasm spasmodic succor succors theorem theorems virus viruses wigged

Word Search in Perl

Compared too the Raku program, Sets and SetHashes are replaced with hashes. There are a few other things done differently, but it is essentially the same idea. Also, I was too lazy to use a separate file for the grid, which I included in a __DATA__ section of the program. For the same reason, I also hard-coded the name of the file containing the list of authorized words.

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

my $dict = "words.txt";
my $min_length = shift // 5;
open my $IN, "<", $dict or die unable to open $dict;
my %words = map { $_ => 1 } grep { length $_ >= $min_length }
    map { chomp; $_ } <$IN>;
close $IN;

my @grid = map { s/[\r\n]+//; [split / /, lc $_]} <DATA>;
my $max_row = $#grid;
my $max_col = $#{$grid[0]}; # scalar @{$grid}[0]} - 1;
my %result;

sub find_words {
    my @row = @{$_[0]};
    for my $i (0..$#row) {
        for my $j ($i+$min_length-1..$#row) {
            my $word = join '', @row[$i..$j];
            $result{$word} = 1 if exists $words{$word};
        }
    }
}

# Horizontal
for my $row (@grid) {
    find_words $_ for $row, [reverse @$row];
}
# Vertical
for my $i (0..$max_col) {
    my @vals = map { $grid[$_][$i] } 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
# Oblique, NW to SE
for my $i (0..$max_col - $min_length + 1) {
    my @vals = grep defined $_, map { $grid[$_][$_+$i] } 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
for my $j (1..$max_row-$min_length+1) {
    my @vals = grep defined $_, map { $grid[$_+$j][$_]} 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
# Oblique, NE to Sw
for my $j ($min_length - 1 .. $max_col) {
    my @vals = grep defined $_, map { $grid[$j-$_][$_] } 0..$max_col;
    find_words $_ for [@vals], [reverse @vals];;
}
for my $i (1 ..$max_row - $min_length + 1) {
    my @vals = grep defined $_, map { $grid[$i+$_][$max_col-$_] }  0..$max_col;
    find_words $_ for [@vals], [reverse @vals];
}  
say join " ", sort keys %result;


__DATA__
B I D E M I A T S U C C O R S T
L D E G G I W Q H O D E E H D P
U S E I R U B U T E A S L A G U
N G N I Z I L A I C O S C N U D
T G M I D S T S A R A R E I F G
S R E N M D C H A S I V E E L I
S C S H A E U E B R O A D M T E
H W O V L P E D D L A I U L S S
R Y O N L A S F C S T A O G O T
I G U S S R R U G O V A R Y O C
N R G P A T N A N G I L A M O O
E I H A C E I V I R U S E S E D
S E T S U D T T G A R L I C N H
H V R M X L W I U M S N S O T B
A E A O F I L C H T O D C A E U
Z S C D F E C A A I I R L N R F
A R I I A N Y U T O O O U T P F
R S E C I S N A B O S C N E R A
D R S M P C U U N E L T E S I L

This program produces the same output as the Raku program:

$ perl letter-grid.pl
aimed align antes arose ashed blunt blunts broad buries clove cloven constitution croon depart departed duddie enter filch garlic goats grieve grieves grith hazard ileac liens lunts malign malignant malls midst midsts ought ovary parted pudgiest quash quashed raias raped roser ruses shrine shrines sices social socializing soyas spasm spasmodic succor succors theorem theorems virus viruses wigged

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

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.