Perl Weekly Challenge 84: Reverse Integer and Find Square Matrices

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

Spoiler Alert: This weekly challenge deadline is due in a few days (November 1, 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: Reverse Integer

You are given an integer $N.

Write a script to reverse the given integer and print the result. Print 0 if the result doesn’t fit in 32-bit signed integer.

The number 2,147,483,647 is the maximum positive value for a 32-bit signed binary integer in computing.

Example 1:

Input: 1234
Output: 4321

Example 2:

Input: -1234
Output: -4321

Example 3:

Input: 1231230512
Output: 0

Note that the minimal value for signed negative integers is - 2 ** 31, i.e. - 2,147,483,648.

Reverse Integer in Raku

We first check if the input integer is negative and, if so, we take its absolute value and record the fact that the input was negative. Then, we just flip the digits. We set the result to 0 if the result exceeds the 32-bit limit for signed integers. We turn the result to a negative integer if the input integer was negative (and, by the way, numify the result to get rid of leading 0’s if any.

use v6;

constant $max = 2 ** 31 - 1; # i.e. 2_147_483_647

my $input = @*ARGS[0] // 1234;
my $positive = True;
if $input < 0 {
    $positive = False;
    $input = -$input;
}
my $output = $input.flip;
$output = 0 if $positive and $output >= $max;
$output = 0 if $output >= $max + 1; # 32-bit negative numbers can go up to 2 ** 31
# No specification for inputs ending with 0
# We numify $output and negate it if needed
$output = $positive ?? +$output !! -$output;
say $output;

Sample output for a few input values:

$ raku reverse-int.raku
4321

$ raku reverse-int.raku -1234
-4321

$ raku reverse-int.raku 1231230512
0

$ raku reverse-int.raku 1231230500
50321321

$ raku reverse-int.raku -1231230500
-50321321

Reverse Integer in Perl

This is simply a port to Perl of the Raku program above, please refer to the explanations above if needed.

use strict;
use warnings;
use feature "say";
use constant MAX => 2 ** 31 - 1; # i.e. 2_147_483_647

my $input = shift  // 1234;
my $positive = 1;
if ($input < 0) {
    $positive = 0;
    $input = -$input;
}
my $output = reverse $input;
$output = 0 if $positive and $output > MAX;
$output = 0 if $output > MAX + 1;
# No specification for inputs ending with 0
# We numify $output and negate it if needed
$output = $positive ? $output + 0 : -$output;
say $output;

Output for a few sample input values:

$ perl reverse-int.pl
4321

$ perl reverse-int.pl -1234
-4321

$ perl reverse-int.pl 1231230512
0

$ perl reverse-int.pl 1231230500
50321321

$ perl reverse-int.pl -1231230500
-50321321

Task 2: Find Square Matrices

You are given matrix of size m x n with only 1 and 0.

Write a script to find the count of squares having all four corners set as 1.

Example 1:

Input: [ 0 1 0 1 ]
       [ 0 0 1 0 ]
       [ 1 1 0 1 ]
       [ 1 0 0 1 ]

Output: 1

Explanation:
There is one square (3x3) in the given matrix with four corners as 1 starts at r=1;c=2.

[ 1 0 1 ]
[ 0 1 0 ]
[ 1 0 1 ]

Example 2:

Input: [ 1 1 0 1 ]
       [ 1 1 0 0 ]
       [ 0 1 1 1 ]
       [ 1 0 1 1 ]

Output: 4

Explanation:
There is one square (4x4) in the given matrix with four corners as 1 starts at r=1;c=1.
There is one square (3x3) in the given matrix with four corners as 1 starts at r=1;c=2.
There are two squares (2x2) in the given matrix with four corners as 1. First starts at r=1;c=1 and second starts at r=3;c=3.

Example 3:

Input: [ 0 1 0 1 ]
       [ 1 0 1 0 ]
       [ 0 1 0 0 ]
       [ 1 0 0 1 ]

Output: 0

Find Square Matrices in Raku

We first define an array of arrays of arrays representing an array of four matrices for our tests. We define a simple print-matrix subroutine to display any matrix in a human-eye friendly format. All the work is done in the find-squares subroutine, which contains three nested for loops: we loop on the possible square matrix sizes (between 2 and the smaller dimension of the input matrix), and then, for each possible size, we loop on each matrix item to see if that item can be the top left corner of a square matrix of the relevant size with each corner set to 1. If any of the four corners is 0, we move to the next item or to the next possible size once we have visited all relevant items with one size. Note that we print much more than what is requested in the task specification because we want to check the results (it would be very easy to remove these extra printed lines by commenting out the say statement near the end of the find-squares subroutine).

my @mat = [ [ [<0 1 0 1>], [<0 0 1 0>], [<1 1 0 1>], [<1 0 0 1>] ], 
            [ [<1 1 0 1>], [<1 1 0 0>], [<0 1 1 1>], [<1 0 1 1>] ],
            [ [<0 1 0 1>], [<1 0 1 0>], [<0 1 0 0>], [<1 0 0 1>] ],
            [ [<1 1 0 1 1 1>], [<1 1 1 0 1 0>], [<1 1 0 1 0 1>], 
                [<1 1 1 0 0 1>] ],
          ];

for @mat -> @m {
    print-matrix @m;
    say "Number of matrices: ", find-squares(@m), "\n";
}
sub print-matrix (@matrix) {
    for @matrix -> @row {
        say '[ ', @row.join(" "), ' ]';
    }
    say " ";
}

sub find-squares (@matrix) {
    my $nb_lines = @matrix.elems;
    my $nb_col = @matrix[0].elems;
    my $nb_squares = 0;
    my $max_square_size = min $nb_lines, $nb_col;
    for 2..$max_square_size -> $square_size {
        for 0..$nb_col - $square_size -> $j {
            for 0..$nb_lines - $square_size -> $i {
                next if @matrix[$i][$j] == 0;
                next if @matrix[$i][$j+$square_size-1] == 0;
                next if @matrix[$i+$square_size-1][$j] == 0;
                next if @matrix[$i+$square_size-1][$j+$square_size-1] == 0;
                say "Value in position $i, $j is the top left corner of a square of size $square_size";
                $nb_squares++;
            }
        }
    }
    return $nb_squares;
}

With the four sample input matrices, the program displays the following results:

[ 0 1 0 1 ]
[ 0 0 1 0 ]
[ 1 1 0 1 ]
[ 1 0 0 1 ]

Value in position 0, 1 is the top left corner of a square of size 3
Number of matrices: 1

[ 1 1 0 1 ]
[ 1 1 0 0 ]
[ 0 1 1 1 ]
[ 1 0 1 1 ]

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 2, 2 is the top left corner of a square of size 2
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 4

[ 0 1 0 1 ]
[ 1 0 1 0 ]
[ 0 1 0 0 ]
[ 1 0 0 1 ]  
Number of matrices: 0

[ 1 1 0 1 1 1 ]
[ 1 1 1 0 1 0 ]
[ 1 1 0 1 0 1 ]
[ 1 1 1 0 0 1 ]

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 1, 0 is the top left corner of a square of size 2
Value in position 2, 0 is the top left corner of a square of size 2
Value in position 1, 0 is the top left corner of a square of size 3
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 3 is the top left corner of a square of size 3
Number of matrices: 6

Find Square Matrices in Perl

This is a port to Perl of the Raku program immediately above, please refer to the explanations above if needed.

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

my @mat = ( [ [ qw<0 1 0 1> ], [ qw<0 0 1 0> ], [ qw<1 1 0 1> ], 
              [ qw<1 0 0 1> ] ], 
            [ [ qw<1 1 0 1> ], [ qw<1 1 0 0> ], [ qw<0 1 1 1> ], 
              [ qw<1 0 1 1> ] ],
            [ [ qw<0 1 0 1> ], [ qw<1 0 1 0> ], [ qw<0 1 0 0> ], 
              [ qw<1 0 0 1> ] ],
            [ [ qw<1 1 0 1 0 1> ], [ qw<1 0 1 0 1 1> ], 
              [ qw<1 1 0 0 1 0> ], [ qw<1 1 0 1 1 1> ] ],
          );

for my $m_ref (@mat) {
    print_matrix($m_ref);
    say "Number of matrices: ", find_squares($m_ref);
}
sub print_matrix {
    my @matrix = @{$_[0]};
    say "";
    for my $row (@matrix) {
        say '[ ', join (" ", @$row), ' ]';
    }
    say " ";
}

sub find_squares {
    my @matrix = @{$_[0]};
    my $nb_lines = scalar @matrix;
    my $nb_col = scalar @{$matrix[0]};
    my $nb_squares = 0;
    my $max_square_size = $nb_lines > $nb_col ? $nb_col : $nb_lines;
    for my $square_size (2..$max_square_size) {
        for my $j (0..$nb_col - $square_size) {
            for my $i (0..$nb_lines - $square_size) {
                next if $matrix[$i][$j] == 0;
                next if $matrix[$i][$j+$square_size-1] == 0;
                next if $matrix[$i+$square_size-1][$j] == 0;
                next if $matrix[$i+$square_size-1][$j+$square_size-1] == 0;
                say "Value in position $i, $j is the top left corner of a square of size $square_size";
                $nb_squares++;
            }
        }
    }
    return $nb_squares;
}

With the four sample input matrices, the program displays the following results:

$ perl square-matrix.pl

[ 0 1 0 1 ]
[ 0 0 1 0 ]
[ 1 1 0 1 ]
[ 1 0 0 1 ]

Value in position 0, 1 is the top left corner of a square of size 3
Number of matrices: 1

[ 1 1 0 1 ]
[ 1 1 0 0 ]
[ 0 1 1 1 ]
[ 1 0 1 1 ]

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 2, 2 is the top left corner of a square of size 2
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 4

[ 0 1 0 1 ]
[ 1 0 1 0 ]
[ 0 1 0 0 ]
[ 1 0 0 1 ]

Number of matrices: 0

[ 1 1 0 1 0 1 ]
[ 1 0 1 0 1 1 ]
[ 1 1 0 0 1 0 ]
[ 1 1 0 1 1 1 ]

Value in position 2, 0 is the top left corner of a square of size 2
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 2

Note that the last example input matrix is not the same as the one in the Raku program, this is the reason why the result is different.

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

Perl Weekly Challenge 83: Words Length and Flip Array

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (October 25, 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: Words Length

You are given a string $S with 3 or more words.

Write a script to find the length of the string except the first and last words ignoring whitespace.

Example 1:

Input: $S = "The Weekly Challenge"

Output: 6

Example 2:

Input: $S = "The purpose of our lives is to be happy"

Output: 23

Words Length in Raku

We take the input string from the command line (but provide a default value in the case no parameter is passed to the script. Then the second code line does essentially all the work: it uses the words built-in method to split the input strings, applies a list slice to the result to remove the first and last words, and joins the result (with an empty separator since we want to ignore whitespace in the letter count). Finally, we use the chars method to find the string length.

use v6;

my $str = @*ARGS[0] // "The purpose of our lives is to be happy";
my $trimmed = join "", $str.words[1..*-2];
say $trimmed.chars;

This is an example output:

$ raku string-length.raku 'The Weekly Challenge'
6

$ raku string-length.raku
23

In fact the code is so simple that we can do it all in a Raku one-liner using chained method invocations:

$ raku -e '@*ARGS[0].words[1..*-2].join('').chars.say'  'The Weekly Challenge'
6

Words Length in Perl

We take the input string from the command line (but provide a default value in the case no parameter is passed to the script. Then we split the input string into the @words array. Finally, we take an array slice to remove the first and the last words, join the words into a string and use the length built-in to find the string length.

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

my $str = $ARGV[0] // "The purpose of our lives is to be happy";
my @words = split /\s+/, $str;
say length join "", @words[1 .. $#words -1];

Sample output:

$ perl  string-length.pl
23

$ perl  string-length.pl 'The Weekly Challenge'
6

We could also solve the problem with a Perl one-liner:

$ perl -E '@w = split /\s+/, shift; say length join "", @w[1 .. $#w -1];' 'The Weekly Challenge'
6

Task 2: Flip Array

You are given an array @A of positive numbers.

Write a script to flip the sign of some members of the given array so that the sum of the all members is minimum non-negative.

Given an array of positive elements, you have to flip the sign of some of its elements such that the resultant sum of the elements of array should be minimum non-negative(as close to zero as possible). Return the minimum no. of elements whose sign needs to be flipped such that the resultant sum is minimum non-negative.

Example 1:

Input: @A = (3, 10, 8)
Output: 1

Explanation:

Flipping the sign of just one element 10 gives the result 1 i.e. (3) + (-10) + (8) = 1

Example 2:

Input: @A = (12, 2, 10)
Output: 1

Explanation:

Flipping the sign of just one element 12 gives the result 0 i.e. (-12) + (2) + (10) = 0

Flip Array in Raku

Given an input limited to three integers as in the provided examples, it seems it wouldn’t be too difficult to find directly the best candidates. But that wouldn’t work too well in the general case with significantly larger input. So, I decided to write a sum-up recursive subroutine to explore all possibilities and find the best candidate. The best candidate will be the smallest non-negative sum. If there are more than one smallest sum, then we look for the solution having the least number of negative integers. Note that we slightly enriched the output compared to what is requested in the task specification, because we wanted to see the solution.

my @a = (defined @*ARGS[0]) ?? @*ARGS !! (5, 5, 8);
my %result;
my @used;
sum-up @a, @used;

sub sum-up (@in is copy, @used-so-far) {
    if @in.elems <= 0 {
        my $sum = [+] @used-so-far;
        %result.push: ($sum => @used-so-far) if $sum >= 0;
    } else {
        my $item = shift @in;
        sum-up(@in, (|@used-so-far, $item));
        sum-up(@in, (|@used-so-far, - $item));
    }
}
my $min-sum = %result.keys.min({+$_});
if %result{$min-sum}[0] ~~ Int {
  say "Sum: $min-sum - digits: %result{$min-sum}";
  say "Number of negative numbers: ", 
    %result{$min-sum}.grep(* < 0).elems;
} else {
  my $min-neg = Inf;
  my $min_neg_index;
  for 0..%result{$min-sum}.end -> $i {
    my $negative_numbers = %result{$min-sum}[$i].grep(* < 0).elems;
    if $negative_numbers < $min-neg {
      $min-neg = $negative_numbers;
      $min_neg_index = $i;
    }
  }

  say "Sum: $min-sum - digits  %result{$min-sum}[$min_neg_index]";
  say "Number of negative numbers: $min-neg";
}

Below are some sample runs:

$ raku min-sum.raku
Sum: 2 - digits: 5 5 -8
Number of negative numbers: 1

$ raku min-sum.raku
Sum: 1 - digits: 3 8 -10
Number of negative numbers: 1

$ raku min-sum.raku 12 2 10
Sum: 0 - digits  -12 2 10
Number of negative numbers: 1

$ raku min-sum.raku 12 2 10 22 7 23
Sum: 2 - digits: -12 -2 10 22 7 -23
Number of negative numbers: 3

Flip Array in Perl

As noted earlier, it wouldn’t be too hard to find directly the best solution with an input of only three integers, as in the examples provided with the task. But that would be much harder with significantly larger input. So, I wrote a sum_up recursive subroutine to explore all possibilities and find the best candidate. The best candidate will be the smallest non-negative sum. If there are more than one smallest sum, then we look for the solution having the least number of negative integers.

use strict;
use warnings;
use feature "say";
use constant INF => 10 ** 12;
use Data::Dumper;

my @a = (defined $ARGV[0]) ? @ARGV : (3, 8, 10);
my %result;
my @used;
sum_up (\@a, \@used);

sub sum_up {
    my @in =  @{$_[0]};
    my @used_so_far =  @{$_[1]};
    if (@in <= 0) {
        my $sum = 0;
        $sum += $_ for @used_so_far;
        push @{$result{$sum}}, [@used_so_far] if $sum >= 0; 
    } else {
        my $item = shift @in;
        sum_up(\@in, [@used_so_far, $item]);
        sum_up(\@in, [@used_so_far, - $item]);
    }
}
# say "Result: \n", Dumper \%result;
my $min_sum = (keys %result)[0];
for my $key (keys %result) {
    $min_sum = $key if $key < $min_sum;
}
if (scalar @{$result{$min_sum}} <= 1) {
    say "Sum: $min_sum - digits: @{$result{$min_sum}[0]}";
    say "Number of negative numbers: ", 
        scalar grep $_ < 0, @{$result{$min_sum}[0]};
} else {
    my $min_neg = INF;
    my $min_neg_index;
    my @candidates = @{$result{$min_sum}};
    for my $i (0..$#candidates) {
        my $negative_numbers = scalar grep $_ < 0, @{$candidates[$i]};
        if ($negative_numbers < $min_neg) {
            $min_neg = $negative_numbers;
            $min_neg_index = $i;
        }
    }
    say "Sum: $min_sum - digits:    @{$candidates[$min_neg_index]}";
    say "Number of negative numbers: $min_neg";
}

Sample runs:

$ perl min-sum.pl
Sum: 1 - digits: 3 8 -10
Number of negative numbers: 1

$ perl min-sum.pl 5 5 8
Sum: 2 - digits: 5 5 -8
Number of negative numbers: 1

$ perl min-sum.pl 12 2 10
Sum: 0 - digits:    -12 2 10
Number of negative numbers: 1

$ perl min-sum.pl  12 2 10 22 7 23
Sum: 2 - digits: -12 -2 10 22 7 -23
Number of negative numbers: 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, November, 1, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 82: Common Factors

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

On Friday, Oct. 16, 2020 around 5:00 p.m., an awful terrorist attack was perpetrated in my home-town of Conflans Sainte-Honorine in France (35,000 inhabitants), the city where I live and of which I am a city councilor. A secondary school teacher was beheaded by a crazy religious extremist who coudn’t accept that teacher’s defense of the freedom of speech. This is a terrible shock to all my fellow citizens, to the teachers and pupils of that school, and to my fellow members of the city council. Because of that, I did not have time to complete the second task of this challenge (although it was almost complete) and my blog post on the first task will be shorter than what I wanted to make. I actually considered not publishing a blog post this week, but I have written at least one blog post for every single Perl Weekly Challenge since the very beginning, I certainly do not want a madman to prevent me from continuing this uninterrupted series of blogs on PWC. And I also don’t want to leave my friend Mohammad S. Anwar alone in the cold.

Common Factors

You are given 2 positive numbers $M and $N.

Write a script to list all common factors of the given numbers.

Example 1:

Input:
    $M = 12
    $N = 18

Output:
    (1, 2, 3, 6)

Explanation:
    Factors of 12: 1, 2, 3, 4, 6
    Factors of 18: 1, 2, 3, 6, 9

Example 2:

Input:
    $M = 18
    $N = 23

Output:
    (1)

Explanation:
    Factors of 18: 1, 2, 3, 6, 9
    Factors of 23: 1

I wanted to give some more explanations, but the short version is that the common factors of two numbers are the factors of the greatest common divisor (GCD) of the two input numbers. So we will compute the GCD of the two numbers and find its divisors.

Common Factors in Raku

Raku has a built-in operator, gcd, to compute the GCD of two numbers.

The code is thus quite simple:

sub common_factors (Int $a, Int $b) {
    my $gcd = $a gcd $b;
    return (1,) if $gcd == 1;
    return ($gcd,) if $gcd.is-prime;
    return (1..$gcd).grep($gcd %% *).unique;
}
my @result = common_factors 12, 18;
say @result;

Output:

raku common_factors.raku
[1 2 3 6]

Common Factors in Perl

Perl doesn’t have a built-in GCD routine. So we will write one using Euclid’s algorithm, or, rather, a modernized version of his algorithm using the % modulo operator, rather than subtraction in the original version of Euclid’s algorithm.

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

sub gcd {
    my ($i, $j) = sort { $a <=> $b } @_;
    while ($j) {
        ($i, $j) = ($j, $i % $j);
    }
    return $i;
}

sub common_factors {
    my ($i, $j) = @_;
    my $gcd = gcd ($i, $j);
    return (1) if $gcd == 1;
    my @factors = grep { $gcd % $_ == 0 } 1..$gcd; 
    my %unique = map {$_ => 1} @factors;
    return sort { $a <=> $b } keys %unique;
}
say join " ", common_factors @ARGV;

Output:

$ perl common_factors.pl 12 18
1 2 3 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, October 25, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 81: Frequency Sort

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

Frequency Sort

You are given file named input.

Write a script to find the frequency of all the words.

It should print the result as the first column of each line should be the frequency of the the word followed by all the words of that frequency arranged in lexicographical order. Also sort the words in the ascending order of frequency.

Input file

West Side Story

The award-winning adaptation of the classic romantic tragedy “Romeo and Juliet”. The feuding families become two warring New York City gangs, the white Jets led by Riff and the Latino Sharks, led by Bernardo. Their hatred escalates to a point where neither can coexist with any form of understanding. But when Riff’s best friend (and former Jet) Tony and Bernardo’s younger sister Maria meet at a dance, no one can do anything to stop their love. Maria and Tony begin meeting in secret, planning to run away. Then the Sharks and Jets plan a rumble under the highway—whoever wins gains control of the streets. Maria sends Tony to stop it, hoping it can end the violence. It goes terribly wrong, and before the lovers know what’s happened, tragedy strikes and doesn’t stop until the climactic and heartbreaking ending.

Note

For the sake of this task, please ignore the following in the input file:

. " ( ) , 's --

Output

1 But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award-winning away become before begin best classic climactic coexist control dance do doesn't end ending escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white whoever wins with wrong younger

2 Bernardo Jets Riff Sharks The by it led tragedy

3 Maria Tony a can of stop

4 to

9 and the

Frequency Sort in Raku

We slurp the full contents of the file into a string, remove the:

. " ( ) , 's --

characters or pairs of characters, use the words method to split the string into words and dump these words into a $h (for histogram) Bag. We then use the %summary hash to dispatch the words according to their frequency. We then iterate over the sorted keys of the hash and output the frequencies and the sorted words for each frequency.

my Str $str = slurp "./WestSideStory.txt";
$str ~~ s:g/<[."(),]>+//;
$str ~~ s:g/[\'s]||['--']//;
my $h = bag $str.words; # histogram by words
my %summary;    # histogram by values
push %summary{$h{$_}}, $_ for $h.keys;
for %summary.keys.sort -> $k {
  say "$k ", %summary{$k}.sort.join(" ");
}

With the West Side Story summary provided above, the following output is displayed:

$ raku frequency-sort.raku
1 But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award-winning away become before begin best classic climactic coexist control dance do doesn't end ending}; escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway whoever hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white wins with wrong younger
2 Bernardo Jets Riff Sharks The by it led tragedy
3 Maria Tony a can of stop
4 to
9 and the

Frequency Sort in Perl

We need to explicitly read the file. We slurp the file into an array and then convert the resulting array into a single string and finally process that string in a way quite similar to what we just did in Raku, except that we use a hash instead of a Bag.

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

my $input = "WestSideStory.txt";
open my $IN, "<", $input or die "Unable to open $input $!";
my @in = <$IN>;
chomp @in;
my $str = join " ", @in;
$str =~ s/[."(),]+//g;
$str =~ s/(\'s)||(--)//g;
my %histogram;
$histogram{$_}++ for split /\s+/, $str;
my %summary;
push @{$summary{$histogram{$_}}}, $_ for keys %histogram;
for my $k (sort {$a <=> $b} keys %summary) {
    say "$k ", join " ", sort @{$summary{$k}};
}

With the West Side Story summary provided above, this program displays the following output:

$ perl frequency-sort.pl
1 But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award-winning away become before begin best classic climactic coexist control dance do doesn't end ending}; escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway whoever hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white wins with wrong younger
2 Bernardo Jets Riff Sharks The by it led tragedy
3 Maria Tony a can of stop
4 to
9 and the

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

Perl Weekly Challenge 80: Smallest Positive Number Bits and Count Candies

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

Spoiler Alert: This weekly challenge deadline is due in several days (October 4, 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: Smallest Positive Number Bits

You are given unsorted list of integers @N.

Write a script to find out the smallest positive number missing.

Example 1:

Input: @N = (5, 2, -2, 0)
Output: 1

Example 2:

Input: @N = (1, 8, -1)
Output: 2

Example 3:

Input: @N = (2, 0, -1)
Output: 1

Smallest Positive Integer Missing in Raku

Our program receives the list of numbers as a parameter (or takes a default list of integers if none is provided). It removes any negative values, sorts the remaining integers, and remove any duplicate (although removing duplicates is not strictly necessary). It then loops through the sorted array, picks the first gap (missing value) into the $result variable and exits the loop. Then it prints the value of result if it is defined, or the last value of the sorted array + 1 if $result is not defined (i.e. if no gap was found).

use v6;

my @nums = @*ARGS.elems > 1 ?? @*ARGS !! (5, 2, -2, 0);
my @sorted = @nums.grep(* >= 0).sort({$^a <=> $^b}).squish;
die "No solution with given input!" if @sorted.elems < 1;
my $result;
for 0..@sorted.end-1 -> $i {
    $result = (@sorted[$i] + 1) and last 
        if @sorted[$i] + 1 < @sorted[$i+1];
}
say $result.defined ?? $result !! @sorted[*-1] + 1;

Of course, a real life program should probably perform some input validation, but a real life program is not very likely to get its input from the command line.

These are the results displayed for a few input lists of integers:

$ raku smallest-missing.raku
1

$ raku smallest-missing.raku 1 8 -1
2

$ raku smallest-missing.raku 2 0 -1
1

$ raku smallest-missing.raku 1 4 3 2 5 8 7 9 4 4 3 2
6

Smallest Positive Integer Missing in Perl

This is a Perl port of the Raku program above (except that it does not remove duplicates). Please refer to the previous section for explanations on how it works.

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

my @nums = @ARGV > 1 ? @ARGV : (5, 2, -2, 0);
my @sorted = sort { $a <=> $b } grep $_ >= 0, @nums;
die "No solution with given input!" if @sorted < 1;
my $result;
for my $i (0..scalar @nums - 1) {
    $result = ($sorted[$i] + 1) and last 
        if $sorted[$i] + 1 < $sorted[$i+1];
}
say $sorted[-1] + 1 and exit unless defined $result;
say  $result ;

The program displays the expected results for a few input list of integers:

$ perl smallest-missing.pl
1

$ perl smallest-missing.pl 1 8 -1
2

$ perl smallest-missing.pl 2 0 -1
1

$ perl smallest-missing.pl 1 4 3 2 5 8 7 9
6

Task 2: Count Candies

You are given rankings of @N candidates.

Write a script to find out the total candies needed for all candidates. You are asked to follow the rules below:

a) You must given at least one candy to each candidate.

b) Candidate with higher ranking get more candies than their immediate neighbors on either side.

Example 1:

Input: @N = (1, 2, 2)

Explanation:

Applying rule #a, each candidate will get one candy. So total candies needed so far 3. Now applying rule #b, the first candidate do not get any more candy as its rank is lower than it's neighbours. The second candidate gets one more candy as it's ranking is higher than it's neighbour. Finally the third candidate do not get any extra candy as it's ranking is not higher than neighbour. Therefore total candies required is 4.

Output: 4

Example 2:

Input: @N = (1, 4, 3, 2)

Explanation:

Applying rule #a, each candidate will get one candy. So total candies needed so far 4. Now applying rule #b, the first candidate do not get any more candy as its rank is lower than it's neighbours. The second candidate gets two more candies as it's ranking is higher than it's both neighbour. The third candidate gets one more candy as it's ranking is higher than it's neighbour. Finally the fourth candidate do not get any extra candy as it's ranking is not higher than neighbour. Therefore total candies required is 7.

Output: 7

Candy Count in Raku

Here, we use an array of three arrays of integers. For each sub-array, we first set $count to the number of values in the sub-array (rule #a), and then loop through the sub-array and increment $count for each neighbor that is smaller than the current value.

use v6;

my @n = [1, 2, 2], [1, 4, 3, 2], [<3 1 5 8 7 4 2>];;
for  @n -> @nums {
    my $count = @nums.elems;
    for 0..@nums.end -> $i {
        $count++ if defined @nums[$i+$_] and 
            @nums[$i] > @nums[$i+$_] for -1, 1;
    }
    say "Total candies required for [@nums[]]: $count.";
}

This program displays the following (correct) output:

raku ./candy_count.raku
Total candies required for [1 2 2]: 4.
Total candies required for [1 4 3 2]: 7.
Total candies required for [3 1 5 8 7 4 2]: 13.

Candy Count in Perl

This is a port to Perl of the Raku program above. Please refer to the explanations in the previous section. As a side note, I was somewhat unhappy some six years ago when I discovered that you cannot get the last element of an array using the -1 subscript in Raku as you would do in Perl ($array[-1]), but would need to use the whatever operator (@array[*-1]). While porting my script to Perl, I initially had a bug, because $num_ref->[$i+$j] was defined (the last item in the array) when $i+$j took the -1 value. This is why I had to add a next statement when $i + $j took a negative value. So, after all, Perl seemed more expressive, but it turns out that Raku is slightly more consistent and a bit less dangerous in such cases.

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

my @n = ([1, 2, 2], [1, 4, 3, 2], [qw<3 1 5 8 7 4 2>]);
for my $num_ref (@n) {
    my $count = scalar @$num_ref;
    for my $i (0..$#$num_ref) {
        for my $j (-1, 1) {
            next if $i + $j < 0;  # avoid negative subscripts
            $count++ if (defined $num_ref->[$i+$j]) and 
                $num_ref->[$i] > $num_ref->[$i+$j];
        }
    }
    say "Total candies required for [@$num_ref]: $count.";
}

This program displays the same output as the Raku program:

$ perl  candy_count.pl
Total candies required for [1 2 2]: 4.
Total candies required for [1 4 3 2]: 7.
Total candies required for [3 1 5 8 7 4 2]: 13.

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