May 2023 Archives

Perl Weekly Challenge 219: Sorted Squares

These are some answers to the Week 219, task 1, 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 June 4, 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.

Sorted Squares

You are given a list of numbers.

Write a script to square each number in the list and return the sorted list, increasing order.

Example 1

Input: @list = (-2, -1, 0, 3, 4)
Output: (0, 1, 4, 9, 16)

Example 2

Input: @list = (5, -4, -1, 3, 6)
Output: (1, 9, 16, 25, 36)

Sorted Squares in Raku

This is quite simple. The program uses a pipeline to chain a code block to replace the input values by their squares (map {$_²}) and the sort routine. Note that, in Raku, the sort built-in function is clever enough to sort numbers numerically and strings lexicographically, so that we don't need to specify the type of sort we want to use. Please also note that the ² postfix operator returns the square of the operand.

sub sorted-squares (@in) {
    return sort map {$_²}, @in;
}

for (-2, -1, 0, 3, 4), (5, -4, -1, 3, 6) -> @test {
    say "@test[]".fmt("%-15s => "), sorted-squares @test;
}

This program displays the following output:

$ raku ./sorted-squares.raku
-2 -1 0 3 4     => (0 1 4 9 16)
5 -4 -1 3 6     => (1 9 16 25 36)

This script is so simple that we can transform it into a Raku one-liner:

$ raku -e 'say sort map {$_²}, @*ARGS' -2 -1 0 3 4
(0 1 4 9 16)

Sorted Squares in Perl

This is a port to Perl of the same data pipeline. Please refer to the above section for explanations if needed. Note that, in Perl, we need to specify that we want a numeric sort (with the {$a <=> $b} block).

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

sub sorted_squares {
    return sort {$a <=> $b} map $_ * $_, @_;
}

for my $test ([-2, -1, 0, 3, 4], [5, -4, -1, 3, 6]) {
    printf "%-15s => ", "@$test";
    say join " ", sorted_squares @$test;
}

This program displays the following output:

$ perl ./sorted-squares.pl
-2 -1 0 3 4     => 0 1 4 9 16
5 -4 -1 3 6     => 1 9 16 25 36

Note that we can also turn this program into a simple Perl one-liner:

$ perl -E 'say join " ", sort {$a <=> $b} map $_ * $_, 
    @ARGV'  2 -1 0 -3 4
0 1 4 9 16

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

Perl Weekly Challenge 218: Maximum Product and Matrix Score

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

Note: the programs presented here were written several days ago, but I was unable to write this blog post in time due to various reasons, including lack of time and some serious problems with my computer.

Task 1: Maximum Product

You are given a list of 3 or more integers.

Write a script to find the 3 integers whose product is the maximum and return it.

Example 1

Input: @list = (3, 1, 2)
Output: 6

1 x 2 x 3 => 6

Example 2

Input: @list = (4, 1, 3, 2)
Output: 24

2 x 3 x 4 => 24

Example 3

Input: @list = (-1, 0, 1, 3, 1)
Output: 3

1 x 1 x 3 => 3

Example 4

Input: @list = (-8, 2, -9, 0, -4, 3)
Output: 216

-9 × -8 × 3 => 216

Maximum Product in Raku

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Since the number of edge cases can become somewhat large, I decided to go to brute force once the first simple cases have been tested with no solution.

sub max-prod (@in) {
    my @list = reverse sort { .abs }, @in;
    return [*] @list[0..2] if @list[0..2].all > 0 
        or @list[0..2].one > 0;
    if @list[0..2].all < 0 {
        # find first positive value to replace one neg
        my $first = @list[3..@list.end].first({ $_ > 0});
        return [*] (@list[0..1], $first).flat if $first.defined;
    } 
    # brute force if we get here
    my @comb-prods = gather {
        for @list.combinations: 3 -> @comb {
            take [*] @comb;
        }
    }
    return @comb-prods.max;
}
for (3, 1, 2), (4, 1, 3, 2), (-1, 0, 1, 3, 1), 
    (-8, 2, -9, 0, -4, 3), (-8, 2, 3, 5, 6) -> @test {
    say "@test[]".fmt("%-15s => "), max-prod @test;
}

This program displays the following output:

$ raku ./max-prod.raku
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90

Maximum Product in Perl

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Note that I decided to go for brute force one step earlier than in Raku.

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

sub prod {
    my $prod = shift;
    $prod *= $_ for @_;
    return $prod;
}

sub max_prod {
    my @list = sort { abs($b) <=> abs($a) } @_;
    return prod @list[0..2] if 0 < prod @list[0..2];
    # brute force if we get here
    my $max = $_[0];
    for my $i (0..$#list) {
        for my $j ($i+1..$#list) { 
            for my $k ($j+1..$#list) {
                my $prod = $list[$i] * $list[$j] * $list[$k];
                $max = $prod if $prod > $max;
            }
        }
    }
    return $max;
}
for my $test ([3, 1, 2], [4, 1, 3, 2], [-1, 0, 1, 3, 1], 
    [-8, 2, -9, 0, -4, 3], [-8, 2, 3, 5, 6]) {
    printf "%-15s => ", "@$test";
    say max_prod @$test;
}

This program displays the following output:

$ perl ./max-prod.pl
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90

Task 2: Matrix Score

You are given a m x n binary matrix i.e. having only 1 and 0.

You are allowed to make as many moves as you want to get the highest score.

A move can be either toggling each value in a row or column.

To get the score, convert the each row binary to dec and return the sum.

Example 1:

Input: @matrix = [ [0,0,1,1],
                   [1,0,1,0],
                   [1,1,0,0], ]
Output: 39

Move #1: convert row #1 => 1100
         [ [1,1,0,0],
           [1,0,1,0],
           [1,1,0,0], ]

Move #2: convert col #3 => 101
         [ [1,1,1,0],
           [1,0,0,0],
           [1,1,1,0], ]

Move #3: convert col #4 => 111
         [ [1,1,1,1],
           [1,0,0,1],
           [1,1,1,1], ]

Score: 0b1111 + 0b1001 + 0b1111 => 15 + 9 + 15 => 39

Example 2:

Input: @matrix = [ [0] ] Output: 1

Matrix Score in Raku

The toggle_col toggles values in a matrix column. The rest of the program is a heuristic approach rather than an algorithm, i.e. it is quite likely to produce the best result or at least something fairly close to it, but there may be some pathological inputs for which the program won’t be able to find the best solution. The main reason for that is that there is no obvious limit to the number of moves. The general idea is to pack as many 1’s as possible in the left rows because they are the most significant digits for the final result.

sub toggle_col (@in, $i) {
    for 0..@in.end -> $j {
        @in[$j][$i] = +not @in[$j][$i];
    }
}
sub improve-score (@in) {
    my $col-max = @in.elems - 1;
    my $row-max = @in[0].elems - 1;
    for @in -> @row {
        if @row[0] == 0 {
            $_ = +not $_ for @row;
        }
    }
    for 0..$row-max -> $index {
        my @col; 
        push @col, @in[$_][$index] for 0..$col-max;
        toggle_col(@in, $index) if @in.elems/2 > [+] @col;
    }
    return @in;
}

my @test = [0,0,1,1], [1,0,1,0], [1,1,0,0];
say "Test: ", @test;
my @new-mat =  improve-score @test;
say "Result: ", @new-mat;
say "Score: ", [+] map {$_.join('').parse-base(2)}, @new-mat;

This program displays the following output:

$ raku ./matrix-score.raku
Test: [[0 0 1 1] [1 0 1 0] [1 1 0 0]]
Result: [[1 1 1 1] [1 0 0 1] [1 1 1 1]]
Score: 39

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

Perl Weekly Challenge 217: Sorted Matrix and Max Number

These are some answers to the Week 217 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 21, 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: Sorted Matrix

You are given a n x n matrix where n >= 2.

Write a script to find 3rd smallest element in the sorted matrix.

Example 1

Input: @matrix = ([3, 1, 2], [5, 2, 4], [0, 1, 3])
Output: 1

The sorted list of the given matrix: 0, 1, 1, 2, 2, 3, 3, 4, 5.
The 3rd smallest of the sorted list is 1.

Example 2

Input: @matrix = ([2, 1], [4, 5])
Output: 4

The sorted list of the given matrix: 1, 2, 4, 5.
The 3rd smallest of the sorted list is 4.

Example 3

Input: @matrix = ([1, 0, 3], [0, 0, 0], [1, 2, 1])
Output: 0

The sorted list of the given matrix: 0, 0, 0, 0, 1, 1, 1, 2, 3.
The 3rd smallest of the sorted list is 0.

Sorted Matrix in Raku

The find-third-smallest subroutine simply sorts the values of the matrix in ascending order and returns the third item of the list (index 2). The only slight difficulty is to properly flatten the matrix data structure into a simple list, which requires here the use of two nested calls to the flat routine. The bulk of the work is done in just one code-line.

sub find-third-smallest (@matrix) {
    return (flat map {.flat}, @matrix).sort[2];
}

for ([3, 1, 2], [5, 2, 4], [0, 1, 3]),
    ([2, 1], [4, 5]),
    ([1, 0, 3], [0, 0, 0], [1, 2, 1])
        -> @test {
    say @test, " => ", find-third-smallest(@test);
}

This program displays the following output:

$ raku ./third-smallest.raku
([3 1 2] [5 2 4] [0 1 3]) => 1
([2 1] [4 5]) => 4
([1 0 3] [0 0 0] [1 2 1]) => 0

Sorted Matrix in Perl

The is no flat routine in Perl, but the task is somewhat easier in Perl than in Raku because, in many situations, Perl automatically flattens the arguments to a subroutine. Note that in Perl, we need the { $a <=> $b } argument to the sort function to force a numeric sort (in Perl, the default is lexicographic sort).

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

sub find_third_smallest {
    return (sort { $a <=> $b } map { @$_ } @_)[2];
}

for my $test ( [ [3, 1, 2], [5, 2, 4], [0, 1, 3] ],
               [ [2, 1], [4, 5] ],
               [ [1, 0, 3], [0, 0, 0], [1, 2, 1] ] ) {
    print map "[@$_] ", @$test;
    say " => ", find_third_smallest @$test;
}

This program displays the following output:

$ perl ./third_smallest.pl [3 1 2] [5 2 4] [0 1 3] => 1 [2 1] [4 5] => 4 [1 0 3] [0 0 0] [1 2 1] => 0

Task 2: Max Number

You are given a list of positive integers.

Write a script to concatenate the integers to form the highest possible value.

Example 1:

Input: @list = (1, 23)
Output: 231

Example 2:

Input: @list = (10, 3, 2)
Output: 3210

Example 3:

Input: @list = (31, 2, 4, 10)
Output: 431210

Example 4:

Input: @list = (5, 11, 4, 1, 2)
Output: 542111

Example 5:

Input: @list = (1, 10)
Output: 110

Basically, we need to reorder the input integers in such a way that numbers starting with the largest digit come first. In other words, we need to perform a lexicographic sort (in descending order) on the input integers. In Raku, implementing this approach could be as simple as this, using the leg operator for comparing various input operands within the sort built-in function:

# Caution: wrong solution
sub reorder (@in) {
    return @in.sort({$^b leg $^a}).join: "";
}

This gives a correct solution for most input lists, but, unfortunately, this doesn’t work as I originally expected for some input lists. For example, if given the (1, 10) input list, the lexicographic sort would produce (10, 1), leading to the number 101, whereas it is obvious that the proper solution is 110.

So, we need some variation to the lexicographic sort in which we would obtain (1, 10).

Max Number in Raku

So, the leg operator sometimes doesn’t work as desired for our purpose when one of the integers to be compared is equal to the beginning of the other, as in the (10, 1) example.

At this point, we could decide to go for a radically different approach, but, since it is quite easy to create new operators in Raku, I decided that I’d rather want to keep the approach and to create my own custom myleg operator to properly handle the special case described above. Basically, it returns the same thing as leg, except when it hits the aforesaid special case.

sub infix:<myleg> ($a, $b) {
    return $a leg $b if $a.chars == $b.chars;
    if $a.chars > $b.chars {
        my $c = substr $a, 0, $b.chars;
        return $a leg $b if $c != $b;
        return (substr $a, $b.chars + 1) leg $c ;
    } else {
        my $c = substr $b, 0, $a.chars;
        return $a leg $b if $c != $a;
        return $c leg (substr $b, $a.chars + 1);    
    }
}    

sub reorder (@in) {
    return @in.sort({$^b myleg $^a}).join: "";
}

for (1, 23), (10, 3, 2), (31, 2, 4, 10), 
    (5, 11, 4, 1, 2), (1, 10), (10, 1), 
    (1, 10), (1, 100), (100, 1) -> @test {
    say "@test[]".fmt("%-15s => "), reorder @test;
}

This program now works as expected and displays the following output:

$ raku ./max-number.raku
1 23            => 231
10 3 2          => 3210
31 2 4 10       => 431210
5 11 4 1 2      => 542111
1 10            => 110
10 1            => 110
1 10            => 110
1 100           => 1100
100 1           => 1100

I got a bit carried away by my original (wrong) solution. The code of the myleg infix operator could be made much simpler:

sub infix:<myleg> ($a, $b) {
    return $a~$b <=> $b~$a;
}

The modified program displays the same output as before.

Max Number in Perl

This is a port to Perl of the Raku program just above. Please refer to the above section for explanations. We cannot create new operators in Perl, but we might as well write a subroutine to be called by the sort function.

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

sub mycmp {
    my ($i, $j) = @_;
    return $i.$j <=> $j.$i;
}

sub reorder {
    return join "", sort { mycmp ($b, $a) } @_;
}

for my $test ([1, 23], [10, 3, 2], [31, 2, 4, 10], 
    [5, 11, 4, 1, 2], [1, 10], [10, 1], 
    [1, 10], [1, 100], [100, 1]) {
    printf "%-15s => ", "@$test";
    say reorder @$test;
}

This program displays the following output:

$ perl ./max-number.pl
1 23            => 231
10 3 2          => 3210
31 2 4 10       => 431210
5 11 4 1 2      => 542111
1 10            => 110
10 1            => 110
1 10            => 110
1 100           => 1100
100 1           => 1100

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

Perl Weekly Challenge 216: Registration Number

These are some answers to the Week 216 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 14, 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: Registration Number

You are given a list of words and a random registration number.

Write a script to find all the words in the given list that has every letter in the given registration number.

Example 1

Input: @words = ('abc', 'abcd', 'bcd'), $reg = 'AB1 2CD'
Output: ('abcd')

The only word that matches every alphabets in the given registration number is 'abcd'.

Example 2

Input: @words = ('job', 'james', 'bjorg'), $reg = '007 JB'
Output: ('job', 'bjorg')

Example 3

Input: @words = ('crack', 'road', 'rac'), $reg = 'C7 RA2'
Output: ('crack', 'rac')

Registration Number in Raku

We first store the letters of the registration number into a Set. Then, we convert each input word into a set of its letter and use the infix (<=) or infix (is a subset of or is equal to) set operator to find whether the input word contains all letters of the registration number.

sub included (@words, $reg) {
    my $letters = $reg.lc.comb.grep({ /<[a..z]>/ }).Set;
    my @result; 
    for @words -> $wd {
        push @result, $wd if $letters ⊆ $wd.lc.comb.Set;
    }
    return @result;
}
my @tests = 
    {words => ('abc', 'abcd', 'bcd'), reg => 'AB1 2CD'}, 
    {words => ('job', 'james', 'bjorg'), reg => '007 JB'},
    {words => ('crack', 'road', 'rac'), reg => 'C7 RA2'};
for @tests -> %test {
    printf "%-30s", "%test<words> - %test<reg> => ";
    say included %test<words>, %test<reg>;
}

This program displays the following output:

$ raku ./registration-nr.raku
abc abcd bcd - AB1 2CD =>     [abcd]
job james bjorg - 007 JB =>   [job bjorg]
crack road rac - C7 RA2 =>    [crack rac]

Registration Number in Perl

This is essentially a port to Perl of the above Raku problem. Since Perl doesn’t have Sets, we use hashes instead, and we use a grep to find out whether there are letters of the registration number that do not belong to the letters of the input words.

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

sub included {
    my @words = @{$_[0]};
    my $reg = lc $_[1];
    # say @words;
    my @letters = grep { /[a-z]/ } split //, $reg;
    # say @letters;
    my @result;
    for my $wd (@words) {
        my %wd_lets = map { $_ => 1 } split //, $wd;
        my @missing = grep { not exists $wd_lets{$_} } @letters;
        push @result, $wd if scalar @missing == 0;
    }
return @result;
}
my @tests = (
    {words => ['abc', 'abcd', 'bcd'], reg => 'AB1 2CD'}, 
    {words => ['job', 'james', 'bjorg'], reg => '007 JB'},
    {words => ['crack', 'road', 'rac'], reg => 'C7 RA2'}
    );
for my $test (@tests) {
    printf "%-30s", "@{$test->{words}} - $test->{reg} => ";
    say join " ", included $test->{words}, $test->{reg};
}

This program displays the following output:

$ perl ./registration.pl
abc abcd bcd - AB1 2CD =>     abcd
job james bjorg - 007 JB =>   job bjorg
crack road rac - C7 RA2 =>    crack rac

Task 2: Word Stickers

I don’t have time right now for this second task. I may be doing it later.

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

Perl Weekly Challenge 215: Odd One Out and Number Placement

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.

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.