laurent_r

These are some answers to the Week 215 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 May 7, 2023 at 23:59). 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: Odd One Out

You are given a list of words (alphabetic characters only) of same size.

Write a script to remove all words not sorted alphabetically and print the number of words in the list that are not alphabetically sorted.

Example 1

Input: @words = ('abc', 'xyz', 'tsu')
Output: 1

The words 'abc' and 'xyz' are sorted and can't be removed.
The word 'tsu' is not sorted and hence can be removed.

Example 2

Input: @words = ('rat', 'cab', 'dad')
Output: 3

None of the words in the given list are sorted.
Therefore all three needs to be removed.

Example 3

Input: @words = ('x', 'y', 'z')
Output: 0

First, I’ll assume that “sorted alphabetically” means sorted in ascending alphabetic order, as alphabetic order almost always means ascending alphabetic order (unless explicitly specified otherwise).

Second, we’re requested to remove from the list all words not sorted alphabetically, but should print only the number of words in the list that are not alphabetically sorted. We don’t really need to remove words not sorted alphabetically to count them.

Last, but not least, the specification is quite ambiguous, but I disagree with example 2: I consider that ‘cab’ and ‘dad’ are properly sorted, just like the two first words of example 1 are sorted. Otherwise, if we had a list of, say, 100 sorted words preceded with just 1 word out of order, we would have to declare that none of the words in the given list are sorted, which hardly makes sense. So, to me, the output for example 2 should be one, as only one word (‘rat’) needs to be removed (or possibly relocated) to obtain a sorted list.

Odd One Out in Raku

This program counts the number of times a word is less than its predecessor in the alphabetic order.

sub find-non-sorted (@in) {
    my @out = @in[0];
    my $count = 0;
    for 1..@in.end -> $i {
        if @in[$i] lt @in[$i-1] {
            $count++;
        } else {
            push @out, @in[$i];
        }
    }
  say @out;
    return $count;
}
for <abc xyz tsu>, <rat cab dad>, <x y z> -> @test {
    printf "%-15s => ", ~@test;
    say find-non-sorted @test;
}

This program displays the following output:

$ raku ./odd-one-out.raku
abc xyz tsu     => 1
rat cab dad     => 1
x y z           => 0

Odd One Out in Perl

This program counts the number of times a word is less than its predecessor in the alphabetic order.

use strict;
use warnings;
use feature 'say';

sub find_non_sorted {
    my @in = @_;
    my @out = $in[0];
    my $count = 0;
    for my $i (1..$#in) {
        if ($in[$i] lt $in[$i-1]) {
            $count++;
        } else {
            push @out, $in[$i];
        }
    }
    # say @out;
    return $count;
}

for my $test ([<abc xyz tsu>], [<rat cab dad>], [<x y z>]) {
    printf "%-15s => ", "@$test";
    say find_non_sorted @$test;
}

This program displays the following output:

$ perl ./odd-one-out.pl
abc xyz tsu     => 1
rat cab dad     => 1
x y z           => 0

Task 2: Number Placement

You are given a list of numbers having just 0 and 1. You are also given placement count (>=1).

Write a script to find out if it is possible to replace 0 with 1 in the given list. The only condition is that you can only replace when there is no 1 on either side. Print 1 if it is possible, otherwise 0.

Example 1:

Input: @numbers = (1,0,0,0,1), $count = 1
Output: 1

You are asked to replace only one 0 as given count is 1.
We can easily replace middle 0 in the list i.e. (1,0,1,0,1).

Example 2:

Input: @numbers = (1,0,0,0,1), $count = 2
Output: 0

You are asked to replace two 0's as given count is 2.
It is impossible to replace two 0's.

Example 3:

Input: @numbers = (1,0,0,0,0,0,0,0,1), $count = 3
Output: 1

Expressing “there is no 1 on either side” in Raku or Perl code is a bit of a pain in the neck, as there are numerous edge cases, notably when the zero or zeros to be removed are at the very beginning or very end of the input list. For example, if we’re trying to remove two zeros, if could be done in lists such as (0,0), (1,0,0,0), or (1,0,0,0,0,1). So, depending on the situation, we may need two, three, or four consecutive zeros to be able to remove two zeros.

To me, the simplest is to convert the input list into a string and to let the regex engine do the bulk of the work, which can be expressed in a single and simple code line both in Raku and Perl..

Number Placement in Raku

We convert the input digits into a string and use the regexes’ negative lookaround assertions to express the “there is no 1 on either side” rule. In the

/ <!after 1> [0 ** {$count}] <!before 1>/

regex, <!after 1> is a negative lookbehind assertion, which means that the group of zeros matched by [0 ** {$count}] should not be preceded by a 1 (it can be either preceded by another zero, or at the beginning of the string. Similarly, <!before 1> is a negative lookahead assertion, meaning that the group of zeros matched by [0 ** {$count}] should not be followed by a 1.

sub find-zeros (@in, $count) {
    return False if $count == 0 or @in.elems < $count;
    my $str = join "", @in;
    return so ($str ~~ / <!after 1> [0 ** {$count}] <!before 1>/)
}

for <0 0 0 1>, <0 0>, <1 0 0 1>, <1 0 0 0 1>, 
    <1 0 0 0 0 0 0 1> -> @test {
    for 0..5 -> $cnt {
        printf "%d - %-16s => ", $cnt, "@test[]";
        say + find-zeros @test, $cnt;
  }
}

This program displays the following output:

$ raku ./number-placement.raku
0 - 0 0 0 1          => 0
1 - 0 0 0 1          => 1
2 - 0 0 0 1          => 1
3 - 0 0 0 1          => 0
4 - 0 0 0 1          => 0
5 - 0 0 0 1          => 0
0 - 0 0              => 0
1 - 0 0              => 1
2 - 0 0              => 1
3 - 0 0              => 0
4 - 0 0              => 0
5 - 0 0              => 0
0 - 1 0 0 1          => 0
1 - 1 0 0 1          => 0
2 - 1 0 0 1          => 0
3 - 1 0 0 1          => 0
4 - 1 0 0 1          => 0
5 - 1 0 0 1          => 0
0 - 1 0 0 0 1        => 0
1 - 1 0 0 0 1        => 1
2 - 1 0 0 0 1        => 0
3 - 1 0 0 0 1        => 0
4 - 1 0 0 0 1        => 0
5 - 1 0 0 0 1        => 0
0 - 1 0 0 0 0 0 0 1  => 0
1 - 1 0 0 0 0 0 0 1  => 1
2 - 1 0 0 0 0 0 0 1  => 1
3 - 1 0 0 0 0 0 0 1  => 1
4 - 1 0 0 0 0 0 0 1  => 1
5 - 1 0 0 0 0 0 0 1  => 0

Number Placement in Perl

This a port to Perl of the Raku program above. Please refer to the previous section for additional explanations. We convert the input digits into a string and use the regexes’ negative lookaround assertions. In Perl, (?<!1) is a negative lookbehind assertion (no 1 before), and (?!1) a negative lookahead assertion (no 1 after).

use strict;
use warnings;
use feature 'say';

sub find_zeros {
    my @in = @{$_[0]};
    my $count = $_[1];
    return 0 if $count == 0 or @in < $count;
    my $str = join "", @in;
    return 1 if $str =~ /(?<!1)0{$count}(?!1)/;
    0;
}

for my $test ([<0 0 0 1>], [<0 0>], [<1 0 0 1>], [<1 0 0 0 1>],
         [<1 0 0 0 0 0 0 1>]) {
    for my $cnt (0..5) {
        printf "%d - %-16s => ", $cnt, "@$test";
        say find_zeros $test, $cnt;
  }
}

This program displays the following output:

$ perl ./number-placement.pl
0 - 0 0 0 1          => 0
1 - 0 0 0 1          => 1
2 - 0 0 0 1          => 1
3 - 0 0 0 1          => 0
4 - 0 0 0 1          => 0
5 - 0 0 0 1          => 0
0 - 0 0              => 0
1 - 0 0              => 1
2 - 0 0              => 1
3 - 0 0              => 0
4 - 0 0              => 0
5 - 0 0              => 0
0 - 1 0 0 1          => 0
1 - 1 0 0 1          => 0
2 - 1 0 0 1          => 0
3 - 1 0 0 1          => 0
4 - 1 0 0 1          => 0
5 - 1 0 0 1          => 0
0 - 1 0 0 0 1        => 0
1 - 1 0 0 0 1        => 1
2 - 1 0 0 0 1        => 0
3 - 1 0 0 0 1        => 0
4 - 1 0 0 0 1        => 0
5 - 1 0 0 0 1        => 0
0 - 1 0 0 0 0 0 0 1  => 0
1 - 1 0 0 0 0 0 0 1  => 1
2 - 1 0 0 0 0 0 0 1  => 1
3 - 1 0 0 0 0 0 0 1  => 1
4 - 1 0 0 0 0 0 0 1  => 1
5 - 1 0 0 0 0 0 0 1  => 0

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