# PERL WEEKLY CHALLENGE – 076

This is my 46th week participating into the weekly challenge.

## TASK #1 › Prime Sum

##### Reviewed by:Ryan Thompson

You are given a number `\$N`. Write a script to find the minimum number of prime numbers required, whose summation gives you `\$N`.

For the sake of this task, please assume `1` is not a prime number.

## Example:

```Input:
\$N = 9

Ouput:
2 as sum of 2 prime numbers i.e. 2 and 7 is same as the input number.
2 + 7 = 9.
```

For the first challenge I just used goldbach conjecture to figure the min primes for a number … basically 2 for evens and 2 or 3 for odds.

Then I just brute forced it.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use Math::Prime::Util qw /factor is_prime/;

my \$N = shift // 9;
say min_primes(\$N);

# Even primes will always have min 2 primes
# Odds will have min 2 or 3
# AKA goldbach conjecture
sub min_primes {
my \$n = shift;

if (is_prime(\$n)) {
}

if (\$n % 2 == 0) {
my \$i = 2;

for (my \$j = \$n - \$i; \$j > 2; \$j--) {
if (is_prime(\$i) && is_prime(\$j)) {
return "\$i + \$j = \$n"
}
\$i++;
}
} else {
my \$i = 2;
my \$possible;

for (my \$k = 0; \$k < \$n - \$i; \$k++ ) {
next if ( \$k != 0
&& ( \$k == 1 || !is_prime(\$k)) );

for (my \$j = \$n - \$i - \$k; \$j > 2; \$j--) {

if ( \$k == 0 && is_prime(\$i)
&& is_prime(\$j) ) {
return "\$i + \$j = \$n";
}

if ( \$k > 0 && is_prime(\$k)
&& is_prime(\$i)
&& is_prime(\$j) ) {
\$possible =  "\$k + \$i + \$j = \$n";
}
\$i++;
}

\$i = 2;
}

return \$possible;
}
}
``````

Output: perl ./ch-1.pl 1212

``11 + 1201 = 1212``

#### Raku solution

``````# Test: perl6 ch-1.p6
our %found;

multi MAIN { MAIN(9) };
multi MAIN(Int \$N) {
say min-primes(\$N);
}

# Even primes will always have min 2 primes
# Odds will have min 2 or 3
# AKA goldbach conjecture
sub min-primes(Int \$n) {

if (\$n.is-prime) {
}

if (\$n % 2 == 0) {
my \$i = 2;

loop (my \$j = \$n - \$i; \$j > 2; \$j--) {
if (\$i.is-prime && \$j.is-prime) {
return "\$i + \$j = \$n";
}
\$i++;
}
} else {
my \$i = 2;
my \$possible;

loop (my \$k = 0; \$k < \$n - \$i; \$k++ ) {
next if ( \$k != 0 &&
(\$k == 1 || !\$k.is-prime) );

loop (my \$j = \$n - \$i - \$k; \$j > 2; \$j--) {
if ( \$k == 0
&& \$i.is-prime
&& \$j.is-prime ) {
return "\$i + \$j = \$n";
}

if ( \$k > 0
&& \$k.is-prime
&& \$i.is-prime && \$j.is-prime ) {
\$possible =  "\$k + \$i + \$j = \$n";
}
\$i++;
}

\$i = 2;
}

return \$possible;
}
}
``````

Output perl6 ch-1.p6 1211

``11 + 1201 = 1212``

## TASK #2 › Word Search

##### Reviewed by:Ryan Thompson

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

For this challenge, I found a good dictionary file on the web as the mac one only found 39 words.

I then loaded the letters into a matrix and the possible words into a hash and proceeded to run a search pattern running from the top left letter to the bottom right, being careful of boundary conditions. Each of the 8 ortho directions were searched against the hash until a boundary was hit.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;
use Data::Dumper;

my \$matrix = letters_to_matrix(shift);
my \$words  = dictionary_to_hash(shift);

my \$max_height = scalar @\$matrix;
my \$max_width  = scalar @{\$matrix->};

# Loop through each letter
# from left to right
for my \$i (0 .. \$max_height - 1) {
for my \$j (0 .. \$max_width - 1) {
find_words(\$matrix, \$words, \$i,
\$j, \$max_height, \$max_width);
}
}

say "Found " . scalar(@answers) . " words:";
say join ', ', sort @answers;

sub find_words {
my (\$matrix, \$words, \$row, \$col, \$h, \$w) = @_;
my @found;

# Orthogonal directions with 1 on top
# 1t 2tr 3r 4br 5b 6bl 7l 8tl
for my \$x (1 .. 8) {
my \$i = \$row;
my \$j = \$col;
my \$possible_word = '';

while (\$i >= 0 && \$j >=0 && \$i < \$h && \$j < \$w) {
\$possible_word .= lc(\$matrix->[\$i][\$j]);

push @found, \$possible_word
if (\$words->{\$possible_word});

# Next position calculations
\$i-- if (\$x == 1 || \$x == 2 || \$x == 8);
\$i++ if (\$x == 4 || \$x == 5 || \$x == 6);
\$j-- if (\$x == 6 || \$x == 7 || \$x == 8);
\$j++ if (\$x == 2 || \$x == 3 || \$x == 4);
}
}

return @found;
}

# Load the letters into a matrix
sub letters_to_matrix {
my \$filename = shift || 'challenge.txt';
my @letter_matrix;

open(my \$fh, '<:encoding(UTF-8)', \$filename) || die "\$@";
while (my \$row = <\$fh>) {
chomp \$row;
my @letters = split (' ', \$row);
push @letter_matrix, \@letters;
}

return \@letter_matrix
}

# Load the dictionary into memory
sub dictionary_to_hash {
my \$filename = shift || 'words.txt';
my %possible_words;

# Challenge only wants words greater
# than 5 so just keep those
open(my \$fh, '<:encoding(UTF-8)', \$filename) || die "\$@";
while (my \$row = <\$fh>) {
chomp \$row;
\$possible_words{lc(\$row)} = 1
if (length(\$row) >= 5);
}
return \%possible_words;
}

``````

Output ./ch-2.pl

``````Found 87 words:
acies, aimed, align, alose, angil, antes, argos, arose, ashed, ation, blunt, blunts, broad, buffa, buries, butea, caeli, clove, cloven, clune, const, constitution, constitutions, cosin, croon, depart, departed, duddie, enter, filch, garlic, goats, grieve, grieves, grith, hazard, hugin, ileac, izing, liens, lunts, malign, malignant, malls, margo, meroe, midst, midsts, neuma, ought, ovary, parte, parted, pasmo, patna, pudgiest, quash, quashed, raias, raped, resor, roser, ruses, shazar, shrine, shrines, sices, social, socializing, soyas, spasm, spasmodic, staun, succor, succors, tallu, talos, talose, theor, theorem, theorems, traci, tracie, virus, viruses, wifie, wigged``````

#### Raku solution

``````# Test: perl6 ch-2.p6

multi MAIN { MAIN("challenge.txt", "words.txt") };
multi MAIN(Str \$letter_file, Str \$word_file) {
my @matrix = letters-to-matrix(\$letter_file);
my %words  = dictionary-to-hash(\$word_file);

my \$max_height = @matrix.elems;
my \$max_width  = @matrix..elems;

for (0 .. \$max_height - 1) -> \$i {
for (0 .. \$max_width - 1) -> \$j {
my @found =
find-words(@matrix, %words, \$i,
\$j, \$max_height, \$max_width);
if @found.elems;
}
}
say "Found " ~  @answers.List.flat.elems ~ " words:";
}

sub find-words(@matrix, %words, \$row, \$col, \$h, \$w) {
my @found;

# Orthogonal directions with 1 on top
# 1t 2tr 3r 4br 5b 6bl 7l 8tl
for (1 .. 8) -> \$x {
my \$i = \$row;
my \$j = \$col;
my \$possible_word = '';

while (\$i >= 0 && \$j >=0 && \$i < \$h && \$j < \$w) {
\$possible_word ~= @matrix.[\$i][\$j].lc;

@found.push(\$possible_word)
if (%words{\$possible_word});

# Next position calculations
\$i-- if (\$x == 1 || \$x == 2 || \$x == 8);
\$i++ if (\$x == 4 || \$x == 5 || \$x == 6);
\$j-- if (\$x == 6 || \$x == 7 || \$x == 8);
\$j++ if (\$x == 2 || \$x == 3 || \$x == 4);
}
}

return @found;
}

# Load the letters into a matrix
sub letters-to-matrix(Str \$filename) {
my @letter_matrix;

for \$filename.IO.lines -> \$line {
my @letters = \$line.split(" ");
@letter_matrix.push(@letters);
}

return @letter_matrix;
}

# Load the dictionary into memory
sub dictionary-to-hash(Str \$filename) {
my %possible_words;

# Challenge only wants words greater
# than 5 so just keep those
for \$filename.IO.lines -> \$line {
%possible_words{\$line.lc} = 1
if (\$line.chars >= 5);
}

return %possible_words
}
``````

Output perl6 ch-2.p6

``````Found 87 words:
acies, aimed, align, alose, angil, antes, argos, arose, ashed, ation, blunt, blunts, broad, buffa, buries, butea, caeli, clove, cloven, clune, const, constitution, constitutions, cosin, croon, depart, departed, duddie, enter, filch, garlic, goats, grieve, grieves, grith, hazard, hugin, ileac, izing, liens, lunts, malign, malignant, malls, margo, meroe, midst, midsts, neuma, ought, ovary, parte, parted, pasmo, patna, pudgiest, quash, quashed, raias, raped, resor, roser, ruses, shazar, shrine, shrines, sices, social, socializing, soyas, spasm, spasmodic, staun, succor, succors, tallu, talos, talose, theor, theorem, theorems, traci, tracie, virus, viruses, wifie, wigged``````

# PERL WEEKLY CHALLENGE – 075

This is my 45th week participating into the weekly challenge.

## TASK #1 › Coins Sum

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)
```

I was quite busy this week so I decided to bet a bit lazy.

For the first challenge I just used Algorithm::Combinatorics combinations_with_repetition to do all the heavy lifting and just outputted the correct combination in perl.

In Raku i decided to some real work and used a recursive algorithm to find the coin combinations. I add a coin into an imaginary bag if the coins are less than the total.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use List::Util qw /sum0/;
use Algorithm::Combinatorics qw(combinations_with_repetition);

my @C = (1, 2, 4);
my \$S = 6;

my \$total = 0;
my \$solutions;

for my \$size (reverse(1 .. \$S)) {
my \$iter = combinations_with_repetition(\@C,\$size);
while (my \$v = \$iter->next) {
if (sum0(@\$v) == \$S) {
\$total++;
\$solutions .= '(' . (join ',', @\$v) . ')' . "\n"
}
}
}

say "Output: " . \$total . ' solutions';
print \$solutions;
``````

Output: perl ./ch-1.pl

``````Output: 6
(1,1,1,1,1,1)
(1,1,1,1,2)
(1,1,2,2)
(1,1,4)
(2,2,2)
(2,4)``````

#### Raku solution

``````# Test: perl6 ch-1.p6
our %found;

sub MAIN() {
my @C = (1, 2, 4);
my \$S = 6;
my @bag = ();
coin-combinations(@C, \$S, @bag);
say "Output: " ~ %found.keys.elems ~ ' solutions';
}

sub coin-combinations(@C, \$S, @bag is copy) {

for (@C) -> \$coin {
@bag.push(\$coin);
if (@bag.sum < \$S) {
coin-combinations(@C, \$S, @bag);
}

if (@bag.sum == \$S) {
my \$key = '(' ~ @bag.sort.join(',') ~ ')';
say \$key unless (%found{\$key});
%found{\$key} = True;
}

@bag.pop;
}
}
``````

Output perl6 ch-1.p6

``````(1,1,1,1,1,1)
(1,1,1,1,2)
(1,1,2,2)
(1,1,4)
(2,2,2)
(2,4)
Output: 6 solutions``````

## TASK #2 › Largest Rectangle Histogram

You are given an array of positive numbers `@A`.

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

## 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).

## Example 2:

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

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

As I mentioned I was a bit lazy this week so for this task I googled an algorithm to find the max largest rectangle which can be found here:

https://www.geeksforgeeks.org/largest-rectangle-under-histogram/

Then creating the histogram was just a matter of formatting text. (this won’t format nicely for 2 digit numbers).

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;
use List::Util qw /max/;

histogram(2, 1, 4, 5, 3, 7);
say "Output: " . largest_rect(2, 1, 4, 5, 3, 7);

say "\n";

histogram(3, 2, 3, 5, 7, 5);
say "Output: " . largest_rect(3, 2, 3, 5, 7, 5);

sub histogram {
my @A = @_;
my \$max = max @A;

for my \$row (reverse (1 ..\$max)) {
printf ("%s ", \$row);
for my \$col (@A) {
if (\$col >= \$row) {
print "# ";
} else {
print "  ";
}
}
print "\n";
}

print "- " x (scalar(@A) + 1) . "\n";
print "  " . (join ' ', @A) . "\n";
}

sub largest_rect {
my @A = @_;

my @stack;
my \$max_area = 0;
my \$stack_top;
my \$i = 0;

while (\$i < scalar(@A)) {
if (!scalar(@stack) || \$A[\$stack[-1]] <= \$A[\$i]) {
push @stack, \$i++;
} else {
\$stack_top = pop @stack;
my \$w = (scalar(@stack)) ?
(\$i - \$stack[-1] - 1) : \$i;
my \$area = \$A[\$stack_top] * \$w;
\$max_area = max(\$max_area, \$area);
}
}

while (@stack) {
\$stack_top = pop @stack;
my \$w = (scalar(@stack)) ?
(\$i - \$stack[-1] - 1) : \$i;
my \$area = \$A[\$stack_top] * \$w;
\$max_area = max(\$max_area, \$area);
}

return \$max_area;
}
``````

Output ./ch-2.pl

``````7           #
6           #
5       #   #
4     # #   #
3     # # # #
2 #   # # # #
1 # # # # # #
- - - - - - -
2 1 4 5 3 7
Output: 12

7         #
6         #
5       # # #
4       # # #
3 #   # # # #
2 # # # # # #
1 # # # # # #
- - - - - - -
3 2 3 5 7 5
Output: 15``````

#### Raku solution

``````# Test: perl6 ch-2.p6

sub MAIN() {
my @A = (2, 1, 4, 5, 3, 7);
histogram(@A);
say "Output: " ~ largest-rect(@A);

say "\n";

my @B = (3, 2, 3, 5, 7, 5);
histogram(@B);
say "Output: " ~ largest-rect(@B);
}

sub histogram(@A) {
my \$max = @A.max;

for (reverse (1 ..\$max)) -> \$row {
print "\$row ";
for (@A) -> \$col {
if (\$col >= \$row) {
print "# ";
} else {
print "  ";
}
}
print "\n";
}

print "- " x (@A.elems + 1) ~ "\n";
print "  " ~ (join ' ', @A) ~ "\n";
}

sub largest-rect(@A) {
my @stack;
my \$max_area = 0;
my \$stack_top;
my \$i = 0;

while (\$i < @A.elems) {
if (!@stack.elems || @A[@stack[*-1]] <= @A[\$i]) {
@stack.push(\$i++);
} else {
\$stack_top = @stack.pop;
my \$w = (@stack.elems) ??
(\$i - @stack[*-1] - 1) !! \$i;
my \$area = @A[\$stack_top] * \$w;
\$max_area = max(\$max_area, \$area);
}
}

while (@stack) {
\$stack_top = @stack.pop;
my \$w = (@stack.elems) ??
(\$i - @stack[*-1] - 1) !! \$i;
my \$area = @A[\$stack_top] * \$w;
\$max_area = max(\$max_area, \$area);
}

return \$max_area;
}
``````

Output perl6 ch-2.p6

``````7           #
6           #
5       #   #
4     # #   #
3     # # # #
2 #   # # # #
1 # # # # # #
- - - - - - -
2 1 4 5 3 7
Output: 12

7         #
6         #
5       # # #
4       # # #
3 #   # # # #
2 # # # # # #
1 # # # # # #
- - - - - - -
3 2 3 5 7 5
Output: 15``````

# PERL WEEKLY CHALLENGE – 074

This is my 44th week participating into the weekly challenge.

## 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 2

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

For the first challenge I just stored the number of times the number appears in a hash (\$counts) and then sorted the hash. If the hash meet the min requirements output the number and if not output -1

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use POSIX qw/ floor /;
use Test::More;

is majority_element(1, 2, 2, 3, 2, 4, 2), 2, '(1, 2, 2, 3, 2, 4, 2)';
is majority_element(1, 3, 1, 2, 4, 5), -1, '(1, 3, 1, 2, 4, 5)';
done_testing;

sub majority_element {
my %counts;
map { \$counts{\$_}++ } @_;

# Majority element
my (\$m) = sort { \$counts{\$b} <=> \$counts{\$a} }
keys %counts;

return (\$counts{\$m} > floor(scalar(@_)/2)) ?
\$m : -1;
}
``````

Output: perl ./ch-1.pl

``````(0, 0, 0,ok 1 - (1, 2, 2, 3, 2, 4, 2)
ok 2 - (1, 3, 1, 2, 4, 5)
1..2``````

#### Raku solution

``````# Test: perl6 ch-1.p6
use Test;

sub MAIN() {
is majority_element((1, 2, 2, 3, 2, 4, 2)), 2, '(1, 2, 2, 3, 2, 4, 2)';
is majority_element((1, 3, 1, 2, 4, 5)), -1, '(1, 3, 1, 2, 4, 5)';
done-testing();
}

sub majority_element(@A) {
my %counts;
@A.map({ %counts{\$_}++ });

# Majority element
my \$m = %counts.keys
.sort({ %counts{\$^b} <=> %counts{\$^a} })
.first;

return (%counts{\$m} > floor(@A.elems/2)) ??
\$m !! -1;
}
``````

Output perl6 ch-1.p6

``````ok 1 - (1, 2, 2, 3, 2, 4, 2)
ok 2 - (1, 3, 1, 2, 4, 5)
1..2``````

## 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 2

#### 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 ‘#’

For this task I just iterated through the array and checked if the letter was unique. If the letter was not unique, I would iterate through the array a second time to find a unique letter. If no unique letters were found display the #

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;
use Test::More;

is fnr('ababc'),  'abb#c', 'ababc';
is fnr('xyzzyx'), 'xyzyx#', 'xyzzyx';
done_testing;

sub fnr {
my @S = split('', shift);
my %counts;
my \$output;

for (my \$i = 0; \$i < scalar(@S); \$i++) {
my \$c = \$S[\$i]; #character
my \$fnr;

# If this is the first time the
# letter exists use it
\$fnr = \$c
if (not defined(\$counts{\$c}));

# Increment counts
\$counts{\$c}++;

# Use the first non repeating
# if there is no duplicate
unless (\$fnr) {
for (my \$j = \$i - 1; \$j >= 0; \$j--) {
my \$c2 = \$S[\$j];
if ( defined(\$counts{\$c2}) &&
\$counts{\$c2} == 1 ) {
\$fnr = \$c2;
last;
}
}
}

# If we didn't find a possible
# frn use a #
\$fnr = '#' unless(\$fnr);

\$output .= \$fnr;
}

return \$output
}
``````

Output ./ch-2.pl

``````ok 1 - ababc
ok 2 - xyzzyx
1..2``````

#### Raku solution

``````# Test: perl6 ch-2.p6
use Test;

sub MAIN() {
is fnr('ababc'),  'abb#c', 'ababc';
is fnr('xyzzyx'), 'xyzyx#', 'xyzzyx';
done-testing();
}

sub fnr(Str \$S) {
my @S = \$S.comb;
my %counts;
my \$output;

loop (my \$i = 0; \$i < @S.elems; \$i++) {
my \$c = @S[\$i]; #character
my \$fnr;

# If this is the first time the
# letter exists use it
\$fnr = \$c
if (not defined(%counts{\$c}));

# Increment counts
%counts{\$c}++;

# Use the first non repeating
# if there is no duplicate
unless (\$fnr) {
loop (my \$j = \$i - 1; \$j >= 0; \$j--) {
my \$c2 = @S[\$j];
if ( defined(%counts{\$c2}) &&
%counts{\$c2} == 1 ) {
\$fnr = \$c2;
last;
}
}
}

# If we didn't find a possible
# frn use a #
\$fnr = '#' unless (\$fnr);

\$output ~= \$fnr;
}

return \$output
}
``````

Output perl6 ch-2.p6

``````ok 1 - ababc
ok 2 - xyzzyx
1..2``````

# PERL WEEKLY CHALLENGE – 073

This is my 43rd week participating into the weekly challenge.

## TASK #1 › Min Sliding Window

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

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

## Example

### Output: (0, 0, 0, 2, 3, 3, 4, 4)

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

I didn’t have time for the challenge this week.

For the first challenge it was just a matter of iterating through the array and and finding the min value. I used Perl’s List::Util and Raku’s native min function to do the dirty work.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use List::Util qw /min/;

my @out;
my @A = (1, 5, 0, 2, 9, 3, 7, 6, 4, 8);
my \$S = 3;

for my \$i (2 .. scalar(@A) - 1) {
push @out, min \$A[\$i], \$A[\$i - 1], \$A[\$i - 2];
}

say '(' . (join ', ', @out) . ')';
``````

Output: perl ./ch-1.pl

``(0, 0, 0, 2, 3, 3, 4, 4)``

#### Raku solution

``````# Test: perl6 ch-1.p6
sub MAIN() {
my @out;
my @A = (1, 5, 0, 2, 9, 3, 7, 6, 4, 8);
my \$S = 3;

for (2 .. @A.elems - 1) -> \$i {
push @out, min @A[\$i], @A[\$i - 1], @A[\$i - 2];
}

say '(' ~ @out.join(", ") ~ ')';
}``````

Output perl6 ch-1.p6

``(0, 0, 0, 2, 3, 3, 4, 4)``

## TASK #2 › Smallest Neighbour

You are given an array of integers `@A`.

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

## Example 2

### Output: (0, 4, 4)

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

For this task I just iterated through the array and kept track of the smallest neighbor to the left of the array

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;

say smallest_neighbor(7, 8, 3, 12, 10);
say smallest_neighbor(4, 6, 5);

sub smallest_neighbor {
my @A = @_;
my @out;
my \$smallest_so_far;

for my \$i (0 .. scalar(@A) - 1) {
if ( defined(\$smallest_so_far) &&
\$A[\$i] > \$smallest_so_far ) {
push @out, \$smallest_so_far;
} else {
push @out, 0;
}

\$smallest_so_far = \$A[\$i]
unless (defined(\$smallest_so_far));

\$smallest_so_far = \$A[\$i]
if (\$smallest_so_far > \$A[\$i]);
}

return '(' . (join ', ', @out) . ')';
}
``````

Output ./ch-2.pl

``````(0, 7, 0, 3, 3)
(0, 4, 4)``````

#### Raku solution

``````# Test: perl6 ch-2.p6
sub MAIN() {
say smallest-neighbor((7, 8, 3, 12, 10));
say smallest-neighbor((4, 6, 5));
}

sub smallest-neighbor(@A) {
my @out;
my \$smallest_so_far;

for (0 .. @A.elems - 1) -> \$i {
if ( defined(\$smallest_so_far) &&
@A[\$i] > \$smallest_so_far ) {
@out.push(\$smallest_so_far);
} else {
@out.push(0);
}

\$smallest_so_far = @A[\$i]
unless (defined(\$smallest_so_far));

\$smallest_so_far = @A[\$i]
if (\$smallest_so_far > @A[\$i]);
}

return '(' ~ @out.join(', ') ~ ')';
}
``````

Output perl6 ch-2.p6

``````(0, 7, 0, 3, 3)
(0, 4, 4)``````

# PERL WEEKLY CHALLENGE – 072

This is my 42nd week participating into the weekly challenge.

## TASK #1 › Trailing Zeroes

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

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

#### Example 3

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

For this challenge, I project calcalated the \$N factorial the old fashioned way by using a for loop.

Calculating the zero’s was a bit more tricky and used an algorithm I read up a while ago to calculate the 0’s based on the 5’s .

This algorithm

Trailing 0s in n! = Count of 5s in prime factors of n!
= floor(n/5) + floor(n/25) + floor(n/125) + ….

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;

my \$N = shift // 20;
die ("N needs to be greated than 1 ")
unless (\$N > 10);

my (\$factorial, \$zeros) = processN(\$N);
say "\$zeros as \$N! = \$factorial has \$zeros trailing zeroes";

sub processN {
my \$N = shift;
my \$factorial = 1;
my \$zeroes = 0;

# Calculate factorial
for (my \$i = 2; \$i <= \$N; \$i++) {
\$factorial *= \$i;
}

# Find zeroes
for (my \$i = 5; int(\$N / \$i) >= 1; \$i *= 5) {
\$zeroes += int(\$N / \$i);
}

return \$factorial, \$zeroes;
}
``````

Output: perl ./ch-1.pl

``4 as 20! = 2432902008176640000 has 4 trailing zeroes``

#### Raku solution

``````# Test: perl6 ch-1.p6
multi MAIN { MAIN(20) };
multi MAIN(Int \$N where \$N > 10) {
my (\$factorial, \$zeros) = processN(\$N);
say "\$zeros as \$N! = \$factorial has \$zeros trailing zeroes";
}

sub processN(Int \$N) {
my \$factorial = 1;
my \$zeroes = 0;

# Calculate factorial
loop (my \$i = 2; \$i <= \$N; \$i++) {
\$factorial *= \$i;
}

# Find zeroes
loop (\$i = 5; Int(\$N / \$i) >= 1; \$i *= 5) {
\$zeroes += Int(\$N / \$i);
}

return \$factorial, \$zeroes;
}
``````

Output perl6 ch-1.p6

``4 as 20! = 2432902008176640000 has 4 trailing zeroe``

## TASK #2 › Lines Range

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

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

## Example

#### Input:

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

```
```\$A = 4 and \$B = 12

```

#### Output:

```    L4
L5
L6
L7
L8
L9
L10
L11
L12
```

For this task it was just a matter of reading the whole file line by line then filtering out the correct line numbers.

I user perl’s \$. operator, and I didn’t know what the raku equivalent was so I just stored the line number in a variable.

Also since I didn’t have an input file readily available i just use the dictionary word file: ‘/usr/share/dict/words’

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;

my \$A = shift // 10;
my \$B = shift // 20;

die ("\$B needs to be >= than \$A")
unless (\$A > 1 && \$B >= \$A);

my \$input_file = '/usr/share/dict/words';

open my \$fh, '<', \$input_file or die "\$input_file: \$!";
while( <\$fh> ) {
if( \$. >= \$A && \$. <= \$B ) {
print \$_;
}
}

close \$fh;
``````

Output ./ch-2.pl

``````Aaron
Aaronic
Aaronical
Aaronite
Aaronitic
Aaru
Ab
aba
Ababdeh
Ababua
abac``````

#### Raku solution

``````# Test: perl6 ch-2.p6
multi MAIN { MAIN(10,20) };
multi MAIN(Int \$A, \$B where \$A > 1 && \$B >= \$A) {
my \$input_file = '/usr/share/dict/words';
my \$line_count = 0;

for '/usr/share/dict/words'.IO.lines -> \$line {
\$line_count++;
say \$line
if (\$line_count >= \$A && \$line_count <= \$B);
}
}
``````

Output perl6 ch-2.p6

``````Aaron
Aaronic
Aaronical
Aaronite
Aaronitic
Aaru
Ab
aba
Ababdeh
Ababua
abac``````

# PERL WEEKLY CHALLENGE – 071

This is my 41st week participating into the weekly challenge.

## TASK #1 › Peak Element

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

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

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

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

## Example 2

##### Peak: [ 47, 32, 39, 36 ]

Not too much to this task, just created an array with the random elements and comparing the values taking care of the edge cases.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;

my \$N = shift // 10;
die ("N needs to be greated than 1 ")
unless (\$N > 1);

my @values;
my @peaks;

# Populate @values
for my \$i (0 .. \$N - 1) {
push @values, int rand(50);

# Check left most peak
push @peaks, \$values[\$i - 1]
if ( \$i == 1 &&
\$values[\$i - 1] >  \$values[\$i] );

# Check middle peaks
push @peaks, \$values[\$i - 1]
if ( \$i > 1 &&
\$values[\$i - 1] >  \$values[\$i] &&
\$values[\$i - 1] >  \$values[\$i - 2]);

# Check last peaks
push @peaks, \$values[\$i]
if ( \$i == \$N - 1 &&
\$values[\$i] > \$values[\$i - 1]);
}

# Output values
say 'Array: ' . '[' . (join ', ', @values) . ']';
say 'Peak:  ' . '[' . (join ', ', @peaks) . ']';
``````

Output: perl ./ch-1.pl 1 10000

``````Array: [39, 15, 44, 15, 14, 8, 37, 16, 46, 34]
Peak:  [39, 44, 37, 46]``````

#### Raku solution

``````# Test: perl6 ch-1.p6
multi MAIN { MAIN(10) };
multi MAIN(Int \$N where \$N > 1) {
my @values;
my @peaks;

# Populate @values
for (0 .. \$N - 1) -> \$i {
@values.push(50.rand.Int);

# Check left most peak
@peaks.push(@values[\$i - 1])
if ( \$i == 1 &&
@values[\$i - 1] >  @values[\$i] );

# Check middle peaks
@peaks.push(@values[\$i - 1])
if ( \$i > 1 &&
@values[\$i - 1] >  @values[\$i] &&
@values[\$i - 1] >  @values[\$i - 2]);

# Check last peaks
@peaks.push(@values[\$i - 1])
if ( \$i == \$N - 1 &&
@values[\$i] > @values[\$i - 1]);
}

# Output values
say 'Array: ' ~ @values.perl;
say 'Peak:  ' ~ @peaks.perl;
}
``````

Output perl6 ch-1.p6

``````Array: [36, 45, 38, 34, 11, 13, 36, 34, 17, 13]
Peak:  [45, 36]``````

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

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

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

## Example

##### Output: 2 -> 3 -> 4 -> 5

For this task I just used the linked list I wrote for a previous challenge 68 and created a remove node routine.

Since this is a single linked list, we had to traverse the linked list to get the total number of nodes. The find the correct index and remove that node.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Mouse;

has 'value' => (
is  => 'rw',
isa => 'Maybe[Int]',
default => sub {
return undef;
}
);

has 'next' => (
is  => 'rw',
default => sub {
return undef
}
);

__PACKAGE__->meta->make_immutable();

use Mouse;
use feature qw /say/;

has 'first'  => (
is  => 'rw',
default => sub {
return undef
}
);

# Create the list
sub create_list {
my (\$self, @values) = @_;
my \$prev_node;

# Populate the list
for my \$value (@values) {
my \$node = LinkedList::Node->new(value => \$value);

# Populate first and next nodes
(\$prev_node) ?
\$prev_node->next(\$node) :
\$self->first(\$node);

# Next
\$prev_node = \$node;
}
}

sub remove_node {
my (\$self, \$n) = @_;

# Loop through the nodes
my \$node = \$self->first;

# find total nodes
my \$total = 0;
while (\$node) {
\$node = \$node->next;
\$total++;
}

# Get the real location
# relative to the first node
\$n = (\$n - 1) % \$total;
\$n = \$total - \$n - 1;

# Initialize for node removal
my \$i = 0;
my \$last_node;
\$node = \$self->first;

# Process each node
while (\$node && \$i <= \$n) {
if (\$i == \$n) {
# First node
(\$last_node) ?
\$last_node->next(\$node->next) :
\$self->first(\$node->next);

# Next node
\$node->next( (\$node->next) ? \$node->next->next : undef);
last;
}

\$last_node = \$node;
\$node = \$node->next;
\$i++;
}
}

sub display_list {
my \$self = shift;

my \$node = \$self->first;
my @keys;

while (\$node) {
push @keys, \$node->value;
\$node = \$node->next;
}

return join ' → ', @keys;
}

__PACKAGE__->meta->make_immutable();

package main;

use Modern::Perl;

# Create lists and remove node
for my \$i (1..6) {
\$ll->create_list(1,2,3,4,5);
say 'When \$N = ' . \$i;
\$ll->remove_node(\$i);
say 'Output: ' . \$ll->display_list;
}
``````

Output ./ch-2.pl

``````When \$N = 1
Output: 1 → 2 → 3 → 4
When \$N = 2
Output: 1 → 2 → 3 → 5
When \$N = 3
Output: 1 → 2 → 4 → 5
When \$N = 4
Output: 1 → 3 → 4 → 5
When \$N = 5
Output: 2 → 3 → 4 → 5
When \$N = 6
Output: 1 → 2 → 3 → 4``````

#### Raku solution

``````# Test: perl6 ch-2.p6
has Int \$.value is rw;
}

# Create the list
method create-list(*@values) {
my \$prev_node;

# Populate the list
for @values -> \$value {
my \$node = LinkedList::Node.new(value => \$value);

# Populate first and next nodes
if (\$prev_node) {
\$prev_node.next = \$node
} else {
self.first = \$node;
}

# Next node
\$prev_node = \$node;
}
}

# Remove node
method remove-node(Int \$n is copy) {
# Loop through the nodes
my \$node = self.first;

# find total nodes
my \$total = 0;
while (\$node) {
\$node = \$node.next;
\$total++;
}

# Get the real location
# relative to the first node
\$n = (\$n - 1) % \$total;
\$n = \$total - \$n - 1;

# Initialize for node removal
my \$i = 0;
my \$last_node;
\$node = self.first;

# Process each node
while (\$node && \$i <= \$n) {
if (\$i == \$n) {
# First node
if (\$last_node) {
\$last_node.next = \$node.next
} else {
self.first = \$node.next;
}

# Next node
\$node.next = (\$node.next) ?? \$node.next.next !! Nil;
last;
}

\$last_node = \$node;
\$node = \$node.next;
\$i++;
}
}

method display-list {
my \$node = self.first;
my @keys;

while (\$node) {
@keys.push(\$node.value);
\$node = \$node.next;
}

return @keys.join(" → ");
}
}

sub MAIN() {
for (1..6) -> \$i {
\$ll.create-list(1,2,3,4,5);
say 'When \$N = ' ~ \$i;
\$ll.remove-node(\$i);
say 'After: ' ~ \$ll.display-list;
}
}
``````

Output perl6 ch-2.p6

``````When \$N = 1
After: 1 → 2 → 3 → 4
When \$N = 2
After: 1 → 2 → 3 → 5
When \$N = 3
After: 1 → 2 → 4 → 5
When \$N = 4
After: 1 → 3 → 4 → 5
When \$N = 5
After: 2 → 3 → 4 → 5
When \$N = 6
After: 1 → 2 → 3 → 4``````

# PERL WEEKLY CHALLENGE – 070

This is my 40th week participating into the weekly challenge.

## TASK #1 › Character Swapping

You are given a string `\$S` of size `\$N`.

You are also given swap count `\$C` and offset `\$O` such that \$C >= 1, \$O >= 1 and \$C + \$O <= \$N.

Write a script to perform character swapping like below:

```\$S[ 1 % \$N ] <=> \$S[ (1 + \$O) % \$N ]
\$S[ 2 % \$N ] <=> \$S[ (2 + \$O) % \$N ]
\$S[ 3 % \$N ] <=> \$S[ (3 + \$O) % \$N ]
...
...
\$S[ \$C % \$N ] <=> \$S[ (\$C + \$O) % \$N ]

```

## Example 1

```Input:
\$S = 'perlandraku'
\$C = 3
\$O = 4

Character Swapping:
swap 1: e <=> n = pnrlaedraku
swap 2: r <=> d = pndlaerraku
swap 3: l <=> r = pndraerlaku

Output:
pndraerlaku
```

For this task, I just coerced the String into an array and just did some array manipulation to swap the characters.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;

say swap_chars('perlandraku', 3, 4);

sub swap_chars {
my (\$S, \$C, \$O) = @_;
my @s = split('', \$S);
my \$N = scalar(@s) - 1;

for (my \$i = 1; \$i <= \$C; \$i++) {
my \$temp           = \$s[\$i % \$N];
\$s[\$i % \$N]        = \$s[(\$i + \$O) % \$N];
\$s[(\$i + \$O) % \$N] = \$temp;
}

return join '', @s;
}
``````

Output: perl ./ch-1.pl 1 10000

``pndraerlaku``

#### Raku solution

``````# Test: perl6 ch-1.p6
sub MAIN() {
say swap-chars('perlandraku', 3, 4);
}

sub swap-chars( Str \$S, Int \$C, Int \$O) {
my \$N = \$S.chars;
my @s = \$S.split('', :skip-empty);

loop (my \$i = 1; \$i <= \$C; \$i++) {
my \$temp           = @s[\$i % \$N];
@s[\$i % \$N]        = @s[(\$i + \$O) % \$N];
@s[(\$i + \$O) % \$N] = \$temp;
}

return @s.join('');
}
``````

Output perl6 ch-1.p6

``pndraerlaku``

## TASK #2 › Gray Code Sequence

You are given an integer `2 <= \$N <= 5`.

Write a script to generate `\$N-bit` gray code sequence.

## 2-bit Gray Code Sequence

```[0, 1, 3, 2]

```

To generate the 3-bit Gray code sequence from the 2-bit Gray code sequence, follow the step below:

```2-bit Gray Code sequence
[0, 1, 3, 2]

Binary form of the sequence
a) S1 = [00, 01, 11, 10]

Reverse of S1
b) S2 = [10, 11, 01, 00]

Prefix all entries of S1 with '0'
c) S1 = [000, 001, 011, 010]

Prefix all entries of S2 with '1'
d) S2 = [110, 111, 101, 100]

Concatenate S1 and S2 gives 3-bit Gray Code sequence
e) [000, 001, 011, 010, 110, 111, 101, 100]

3-bit Gray Code sequence
[0, 1, 3, 2, 6, 7, 5, 4]

```

## Example

```Input: \$N = 4

Output: [0, 1, 3, 2, 6, 7, 5, 4, 12, 13, 15, 14, 10, 11, 9, 8]
```

This one just involved some string manipulation and converting the bit string to an integer.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;

say gray_code(4);

sub gray_code {
my \$N = shift;
my @S1 = ('00','01','11','10');

while (\$N > 2) {
# Flip the array
my @S2 = reverse @S1;

# Prefix
@S1 = map { '0' . \$_ } @S1;
@S2 = map { '1' . \$_ } @S2;

# Concatenate
push @S1, @S2;

\$N--;
}

# Convert to decimal
@S1 = map { oct("0b" . \$_) } @S1;

return '[' . (join ', ', @S1) . ']';
}
``````

Output ./ch-2.pl

``[0, 1, 3, 2, 6, 7, 5, 4, 12, 13, 15, 14, 10, 11, 9, 8]``

#### Raku solution

``````# Test: perl6 ch-2.p6
sub MAIN() {
say gray-code(4);
}

sub gray-code(Int \$N is copy where \$N >= 2 && \$N <=5 ) {
my @S1 = ('00','01','11','10');

while (\$N > 2) {
# Flip the array
my @S2 = @S1.reverse;

# Prefix
@S1 = @S1.map({ '0' ~ \$_ });
@S2 = @S2.map({ '1' ~ \$_ });

# Concatenate
@S1 = flat @S1, @S2;

\$N--;
}

# Convert to decimal
@S1 = @S1.map({ "0b\$_".Int });

return @S1.perl;
}
``````

Output perl6 ch-2.p6

``[0, 1, 3, 2, 6, 7, 5, 4, 12, 13, 15, 14, 10, 11, 9, 8]``

# PERL WEEKLY CHALLENGE – 069

This is my 39th week participating into the weekly challenge.

## TASK #1 › Strobogrammatic Number

A strobogrammatic number is a number that looks the same when looked at upside down.

You are given two positive numbers `\$A` and `\$B` such that `1 <= \$A <= \$B <= 10^15`.

Write a script to print all strobogrammatic numbers between the given two numbers.

## Example

```Input: \$A = 50, \$B = 100
Output: 69, 88, 96
```

For this challenge I read up on the strobogrammatic number https://en.wikipedia.org/wiki/Strobogrammatic_number.

Then I came up with a simple algorithm to test if a number is a strobogrammatic number.

X is a strobogrammatic number if we remove all numbers that are able to flip be flipped or mirrored. If there are no numbers after the removal process then X is a strobogrammatic number.

First we check for 6 and 9 combinations, then remove 1, 0 and 8’s

For example this is a strobogrammatic number:
66188199
618819
1881
88

This is not:
661858199
6185819
18581
858
5

Because 5 remains

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl 50 100
use Modern::Perl;

my \$a = shift;
my \$b = shift;

die "Invalid inputs"
if ( !\$a || !\$b || \$a > \$b ||
\$a < 0 || \$b > 10e15 );

# Process each number
for my \$i (\$a .. \$b) {
my \$orig = \$i;

# Check and remove 6/9, 9/6 0/0, 1/1, 8/8 pairs
my \$search_length = length(\$i) / 2;
for (my \$j = 0; \$j < \$search_length; \$j++) {
my \$p1 = substr \$i, \$j, 1;
my \$p2 = substr \$i, length(\$i) - \$j - 1, 1;

if ( (\$p1 == 6 && \$p2 == 9) ||
(\$p1 == 9 && \$p2 == 6) ||
(\$p1 == 0 && \$p2 == 0) ||
(\$p1 == 8 && \$p2 == 8) ||
(\$p1 == 1 && \$p2 == 1)) {
\$i = substr \$i, 1, length(\$i) - 2;
\$j--;
\$search_length--;
} else {
last;
}
}

unless (\$i);
}

``````

Output: perl ./ch-1.pl 1 10000

``1, 8, 11, 69, 88, 96, 101, 111, 181, 609, 619, 689, 808, 818, 888, 906, 916, 986, 1001, 1111, 1691, 1881, 1961, 6009, 6119, 6699, 6889, 6969, 8008, 8118, 8698, 8888, 8968, 9006, 9116, 9696, 9886, 9966``

#### Raku solution

``````# Test: perl6 ch-1.p6
sub MAIN(Int \$a where \$a > 0, Int \$b where \$b < 10e15) {
for (\$a .. \$b) -> \$orig_i {
my \$i = \$orig_i.Str;

# Check and remove 6/9, 9/6 0/0, 1/1, 8/8 pairs
my \$search_length = \$i.chars / 2;
loop (my \$j = 0; \$j < \$search_length; \$j++) {
my \$p1 = \$i.substr(\$j, 1);
my \$p2 = \$i.substr(\$i.chars - \$j - 1, 1);

if ( (\$p1 eq '6' && \$p2 eq '9') ||
(\$p1 eq '9' && \$p2 eq '6') ||
(\$p1 eq '0' && \$p2 eq '0') ||
(\$p1 eq '8' && \$p2 eq '8') ||
(\$p1 eq '1' && \$p2 eq '1')) {
\$i = \$i.substr(1, \$i.chars - 2);
\$j--;
\$search_length--;
} else {
last;
}

unless (\$i);
}
}

}
``````

Output perl6 ch-1.p6

``1, 8, 11, 69, 88, 96, 101, 111, 181, 609, 619, 689, 808, 818, 888, 906, 916, 986, 1001, 1111, 1691, 1881, 1961, 6009, 6119, 6699, 6889, 6969, 8008, 8118, 8698, 8888, 8968, 9006, 9116, 9696, 9886, 9966``

## TASK #2 › 0/1 String

`0/1 string` is a string in which every character is either 0 or 1.

Write a script to perform `switch` and `reverse` to generate `S1000` as described below:

```switch:

Every 0 becomes 1 and every 1 becomes 0. For example, “101” becomes “010”.

reverse:

The string is reversed. For example, "001” becomes “100”.

```

To generate `S1000` string, please follow the rule as below:

```S0 = “”
S1 = “0”
S2 = “001”
S3 = “0010011”
…
SN = SN-1 + “0” + switch(reverse(SN-1))
```

Not much to this one, just manipulate the string and make a function to return Sn.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;
use Test::More;

is (s_thousand(''),            '0',      'Test: Empty string');
is (s_thousand('0'),         '001',      'Test: 0');
is (s_thousand('001'),   '0010011',      'Test: 001');
done_testing();

# s1000
sub s_thousand {
my \$string = shift;
return \$string . "0" . s_switch(scalar reverse(\$string));
}

# Switch
sub s_switch {
my \$string = shift;
\$string =~ tr/01/10/;
return \$string;
}
``````

Output ./ch-2.pl

``````ok 1 - Test: Empty string
ok 2 - Test: 0
ok 3 - Test: 001
1..3``````

#### Raku solution

``````# Test: perl6 ch-2.p6
use Test;

sub MAIN() {
is s-thousand(''),            '0',      'Test: Empty string';
is s-thousand('0'),         '001',      'Test: 0';
is s-thousand('001'),   '0010011',      'Test: 001';
done-testing();
}

# s1000
sub s-thousand(Str \$s) {
return \$s ~ "0" ~ s-switch(\$s.flip);
}

# Switch
sub s-switch(Str \$s is copy) {
\$s ~~ tr/01/10/;
return \$s;
}
``````

Output perl6 ch-2.p6

``````ok 1 - Test: Empty string
ok 2 - Test: 0
ok 3 - Test: 001
1..3``````

# PERL WEEKLY CHALLENGE – 068

This is my 38th week participating into the weekly challenge.

## TASK #1 › Zero Matrix

You are given a matrix of size `M x N` having only `0s` and `1s`.

Write a script to set the entire row and column to `0` if an element is `0`.

## Example 1

```Input: [1, 0, 1]
[1, 1, 1]
[1, 1, 1]

Output: [0, 0, 0]
[1, 0, 1]
[1, 0, 1]

```

## Example 2

```Input: [1, 0, 1]
[1, 1, 1]
[1, 0, 1]

Output: [0, 0, 0]
[1, 0, 1]
[0, 0, 0]
```

For this challenge, I just create a function `zero` that initialed a cloned matrix with values of 1 and just zero’s out the rows and columns by looping through each item of the original matrix, checking if it’s 0, then zeroing out the columns and rows.,

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use Algorithm::Combinatorics qw(combinations);

my \$m1 = [ [1, 0, 1],
[1, 1, 1],
[1, 1, 1], ];

my \$m2 = [ [1, 0, 1],
[1, 1, 1],
[1, 0, 1], ];

for my \$m (\$m1, \$m2) {
say "Input:";
print_matrix(\$m);

say "Output:";
print_matrix(zero(\$m));
}

# Zero our columns and rows
sub zero {
my \$m = shift;

# Lengths of the matrix
my \$l1 = scalar(@\$m);
my \$l2 = scalar(@{\$m->});

# Initialize new matrix
my \$m2 = [];
for (my \$i = 0; \$i < \$l1; \$i++) {
\$m2->[\$i] = [];
for (my \$j = 0; \$j < \$l2; \$j++) {
\$m2->[\$i][\$j] = 1;
}
}

# Process each element of the matrix
for (my \$i = 0; \$i < \$l1; \$i++) {
for (my \$j = 0; \$j < \$l2; \$j++) {
if (\$m->[\$i][\$j] == 0) {
# zero our rows
\$m2->[\$i][\$_] = 0
for (0 .. \$l2- 1 );

# zero our cols
\$m2->[\$_][\$j] = 0 #
for (0 .. \$l1 - 1)
}
}
}

# Return new matrix
return \$m2;
}

# Print the matrix
sub print_matrix {
my \$m = shift;
my \$l1 = scalar(@\$m);
my \$l2 = scalar(@{\$m->});

# Process each element of the matrix
for (my \$i = 0; \$i < \$l1; \$i++) {
print '[ ';
for (my \$j = 0; \$j < \$l2; \$j++) {
printf ('%3s', \$m->[\$i][\$j]);
}
say ' ]';
}

say '';
}
``````

Output: perl ./ch-1.pl

``````# Test: perl6 ch-1.p6
sub MAIN() {
my @m1 = [ [1, 0, 1],
[1, 1, 1],
[1, 1, 1], ];

my @m2 = [ [1, 0, 1],
[1, 1, 1],
[1, 0, 1], ];

for (@m1, @m2) -> \$m {
say "Input:";
print-matrix(\$m);

say "Output:";
print-matrix(zero(\$m));
}
}

# Zero our columns and rows
sub zero(@m) {
# Initialize new matrix
my \$m2 = [];
for (^@m) -> \$i {
\$m2.[\$i] = [];
for (^@m.) -> \$j {
\$m2.[\$i][\$j] = 1;
}
}

# Process each element of the matrix
for (^@m) -> \$i {
for (^@m.) -> \$j {
if (@m.[\$i][\$j] == 0) {
# zero our rows
for (^@m) -> \$k {
\$m2.[\$k][\$j] = 0;
}

# zero out cols
for (^@m.) -> \$k {
\$m2.[\$i][\$k] = 0;
}
}
}
}

# Return new matrix
return \$m2;
}

# Print the matrix
sub print-matrix(@m) {
my \$l1 = @m.elems;
my \$l2 = @m..elems;

# Process each element of the matrix
for (^@m) -> \$i {
print '[ ';
for (^@m.) -> \$j  {
'%3s'.printf(@m.[\$i][\$j].perl);
}
say ' ]';
}

say '';
}
``````

#### Raku solution

``````# Test: perl6 ch-1.p6
sub MAIN() {
my @m1 = [ [1, 0, 1],
[1, 1, 1],
[1, 1, 1], ];

my @m2 = [ [1, 0, 1],
[1, 1, 1],
[1, 0, 1], ];

for (@m1, @m2) -> \$m {
say "Input:";
print-matrix(\$m);

say "Output:";
print-matrix(zero(\$m));
}
}

# Zero our columns and rows
sub zero(@m) {
# Initialize new matrix
my \$m2 = [];
for (^@m) -> \$i {
\$m2.[\$i] = [];
for (^@m.) -> \$j {
\$m2.[\$i][\$j] = 1;
}
}

# Process each element of the matrix
for (^@m) -> \$i {
for (^@m.) -> \$j {
if (@m.[\$i][\$j] == 0) {
# zero our rows
for (^@m) -> \$k {
\$m2.[\$k][\$j] = 0;
}

# zero out cols
for (^@m.) -> \$k {
\$m2.[\$i][\$k] = 0;
}
}
}
}

# Return new matrix
return \$m2;
}

# Print the matrix
sub print-matrix(@m) {
my \$l1 = @m.elems;
my \$l2 = @m..elems;

# Process each element of the matrix
for (^@m) -> \$i {
print '[ ';
for (^@m.) -> \$j  {
'%3s'.printf(@m.[\$i][\$j].perl);
}
say ' ]';
}

say '';
}
``````

Output perl6 ch-1.p6

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

Output:
[   0  0  0 ]
[   1  0  1 ]
[   1  0  1 ]

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

Output:
[   0  0  0 ]
[   1  0  1 ]
[   0  0  0 ]``````

## TASK #2 › Reorder List

You are given a singly linked list `\$L` as below:

```L0 →  L1 →  … →  Ln-1 →  Ln

```

Write a script to reorder list as below:

```L0 →  Ln →  L1 →  Ln-1 →  L2 →  Ln-2 →

```

You are ONLY allowed to do this in-place without altering the nodes’ values.

## Example

```Input:  1 →  2 →  3 →  4
Output: 1 →  4 →  2 →  3
```

For this challenge I just created a linked list using, Perl’s Mouse OO framework and Raku’s built-in `Class` Object.

Reordering the list is just a matter off moving some references around. Look at the `reorder_list` for how it’s done. The tricky bit was handling the edge case of processing the final traversed node.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Mouse;

has 'value' => (
is  => 'rw',
isa => 'Maybe[Int]',
default => sub {
return undef;
}
);

has 'next' => (
is  => 'rw',
default => sub {
return undef
}
);

__PACKAGE__->meta->make_immutable();

use Mouse;
use feature qw /say/;

has 'first'  => (
is  => 'rw',
default => sub {
return undef
}
);

# Create the list
sub create_list {
my (\$self, @values) = @_;
my \$prev_node;

# Populate the list
for my \$value (@values) {
my \$node = LinkedList::Node->new(value => \$value);

# Populate first and next nodes
(\$prev_node) ?
\$prev_node->next(\$node) :
\$self->first(\$node);

# Next
\$prev_node = \$node;
}
}

sub reorder_list {
my (\$self, \$k) = @_;

# Loop through the nodes
my \$node = \$self->first;

# Process each node
while (\$node) {
my \$next_node = \$node->next;
my \$traverse_node = \$node;
my \$last_node = \$node;

while (\$traverse_node->next) {
\$last_node = \$traverse_node;
\$traverse_node = \$traverse_node->next;
}

\$node->next(\$traverse_node);

if (\$next_node && \$next_node->next) {
\$traverse_node->next(\$next_node);
\$last_node->next(undef);
} else {
\$traverse_node->next(undef);
}

\$node = \$next_node;
}
}

sub display_list {
my \$self = shift;

my \$node = \$self->first;
my @keys;

while (\$node) {
push @keys, \$node->value;
\$node = \$node->next;
}

return join ' → ', @keys;
}

__PACKAGE__->meta->make_immutable();

package main;

use Modern::Perl;

\$ll->create_list(1,2,3,4);
say 'Before: ' . \$ll->display_list;
\$ll->reorder_list();
say 'After: ' . \$ll->display_list;
``````

Output ./ch-2.pl

``````Before: 1 → 2 → 3 → 4
After: 1 → 4 → 2 → 3``````

#### Raku solution

``````# Test: perl6 ch-2.p6
has Int \$.value is rw;
}

# Create the list
method create-list(*@values) {
my \$prev_node;

# Populate the list
for @values -> \$value {
my \$node = LinkedList::Node.new(value => \$value);

# Populate first and next nodes
if (\$prev_node) {
\$prev_node.next = \$node
} else {
self.first = \$node;
}

# Next node
\$prev_node = \$node;
}
}

method reorder-list(Int \$k) {
# Loop through the nodes
my \$node = self.first;

# Process each node
while (\$node) {
my \$next_node = \$node.next;
my \$traverse_node = \$node;
my \$last_node = \$node;

while (\$traverse_node.next) {
\$last_node = \$traverse_node;
\$traverse_node = \$traverse_node.next;
}

# Move the nodes around
\$node.next = \$traverse_node;
if (\$next_node && \$next_node.next) {
\$traverse_node.next = \$next_node;
\$last_node.next = Nil;
} else {
\$traverse_node.next = Nil;
}

# Next node
\$node = \$next_node;
}
}

method display-list {
my \$node = self.first;
my @keys;

while (\$node) {
@keys.push(\$node.value);
\$node = \$node.next;
}

return @keys.join(" → ");
}
}

sub MAIN() {
\$ll.create-list(1,2,3,4);
say 'Before: ' ~ \$ll.display-list;
\$ll.reorder-list(3);
say 'After: ' ~ \$ll.display-list;
}
``````

Output perl6 ch-2.p6

``````Before: 1 → 2 → 3 → 4
After: 1 → 4 → 2 → 3``````

# PERL WEEKLY CHALLENGE – 067

This is my 37th week participating into the weekly challenge.

## TASK #1 › Number Combinations

You are given two integers `\$m` and `\$n`. Write a script print all possible combinations of `\$n` numbers from the list 1 2 3 … \$m.

Every combination should be sorted i.e. [2,3] is valid combination but [3,2] is not.

## Example:

```Input: \$m = 5, \$n = 2

Output: [ [1,2], [1,3], [1,4], [1,5], [2,3], [2,4], [2,5], [3,4], [3,5], [4,5] ]
```

For this challenge, I brute forced the solution using perl’s https://metacpan.org/pod/Algorithm::Combinatorics and raku’s combinations method.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use Modern::Perl;
use Algorithm::Combinatorics qw(combinations);

# Default \$m and \$n
my \$m = shift // 5;
my \$n = shift // 2;

my @combinations = numeric_combinations(\$m, \$n);

sub numeric_combinations {
my (\$m, \$n) = @_;
my @data = (1 .. \$m);

# Possible combinations
return my @all_combinations
= combinations(\@data, \$n);
}

# Flaten to answer array to a string
my \$combinations = shift;
return
'[ ' .
(
join ', ',
map {
'[' .
(join ', ', @\$_) .
']'
} @\$combinations
) .
' ]';
}
``````

Output: perl ./ch-1.pl

``[ [1, 2], [1, 3], [1, 4], [1, 5], [2, 3], [2, 4], [2, 5], [3, 4], [3, 5], [4, 5] ]``

#### Raku solution

``````# Test: perl6 ch-1.p6
multi MAIN() { MAIN(5, 2); }

multi MAIN(Int \$m, Int \$n) {
my @data = (1 .. \$m);
say @data.combinations: \$n;
}``````

Output perl6 ch-1.p6

``((1 2) (1 3) (1 4) (1 5) (2 3) (2 4) (2 5) (3 4) (3 5) (4 5))``

## TASK #2 › Letter Phone

You are given a digit string `\$S`. Write a script to print all possible letter combinations that the given digit string could represent.

## Example:

```Input: \$S = '35'

Output: ["dj", "dk", "dl", "ej", "ek", "el", "fj", "fk", "fl"].
```

For this challenge I just brute forced to solution by splitting the first letter out of the word and using recursion to generate the possible combinations of the rest of the word.

For example ’35’ becomes:
combos(’35’)

Recursions:
‘d’ . combos(‘5’)
‘e’ . combos(‘5’)
‘d’ . combos(‘5’)

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use Modern::Perl;

# Default \$m and \$n
my \$S = shift // '35';

# Phone key transations
my \$phone_keys = {
1 => ['_', ',', '@'],
2 => ['a', 'b', 'c'],
3 => ['d', 'e', 'f'],
4 => ['g', 'h', 'i'],
5 => ['j', 'k', 'l'],
6 => ['m', 'n', 'o'],
7 => ['p', 'q', 'r', 's'],
8 => ['t', 'u', 'v'],
9 => ['w', 'x', 'y', 'z'],
};

say
'[ "' .
( join '", "',
combos(\$S)
) .
'" ]';

# Generate the possible combinations
sub combos {
my \$S = shift;

my (\$letter, \$rest_of_word) =
split('',\$S,2);

for my \$l (@{\$phone_keys->{\$letter}}) {
if (\$rest_of_word) {
combos(\$rest_of_word);

map { \$l . \$_}
} else {
}
}

}
``````

Output ./ch-2.pl

``[ "dj", "dk", "dl", "ej", "ek", "el", "fj", "fk", "fl" ]``

#### Raku solution

``````# Test: perl6 ch-1.p6

# Phone key transations
my %phone_keys = (
'1' => ['_', ',', '@'],
'2' => ['a', 'b', 'c'],
'3' => ['d', 'e', 'f'],
'4' => ['g', 'h', 'i'],
'5' => ['j', 'k', 'l'],
'6' => ['m', 'n', 'o'],
'7' => ['p', 'q', 'r', 's'],
'8' => ['t', 'u', 'v'],
'9' => ['w', 'x', 'y', 'z'],
'*' => ['_'],
'0' => [''],
'#' => [''],
);

multi MAIN() { MAIN('35'); }

multi MAIN(Str \$S) {
say combos(\$S).perl;
}

# Generate the possible combinations
sub combos(Str \$S) {

my \$letter = \$S.substr(0, 1);
my \$rest_of_word = \$S.substr(1);

for (@(%phone_keys{\$letter})) -> \$l {
if (\$rest_of_word) {
combos(\$rest_of_word);
``["dj", "dk", "dl", "ej", "ek", "el", "fj", "fk", "fl"]``