# PERL WEEKLY CHALLENGE – 073

This is my 43th 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 42th 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 41th 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);
} else {
}
}

}
``````

Output perl6 ch-2.p6

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

# PERL WEEKLY CHALLENGE – 066

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

## TASK #1 › Divide Integers

You are given two integers `\$M` and `\$N`.

Write a script to divide the given two integers i.e. `\$M / \$N` without using multiplication, division and mod operator and return the floor of the result of the division.

#### Example 1:

```Input: \$M = 5, \$N = 2
Output: 2

```

#### Example 2:

```Input: \$M = -5, \$N = 2
Output: -2

```

## Example 3:

```Input: \$M = -5, \$N = -2
Output: 2
```

#### Example

```Input:
\$N = 2
\$S = 4

Output:
13, 22, 31, 40
```

For this challenge, i just used subtraction to divide, like one would use multiplication to add.

#### Perl 5 solution

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

is (divide(5,2),   2,  'Divide 5 , 2');
is (divide(-5,2), -3,  'Divide -5 , 2');
is (divide(-5,-2), 2,  'Divide -5 , -2');
done_testing();

sub divide {
my (\$M, \$N) = @_;
my \$quotient = 0;
my \$negative = 0;

if (\$M < 0 && \$N > 0) {
\$negative = 1;
\$M = - \$M;
} elsif (\$M > 0 && \$N < 0) {
\$negative = 1;
\$N = - \$N;
} elsif (\$M < 0 && \$N < 0) {
\$M = - \$M;
\$N = - \$N;
}

while (\$M > \$N) {
\$M = \$M - \$N;
\$quotient++;
}

return (\$negative) ?
- \$quotient - 1 : \$quotient;
}
``````

Output: perl ./ch-1.pl

``````ok 1 - Divide 5 , 2
ok 2 - Divide -5 , 2
ok 3 - Divide -5 , -2
1..3``````

#### Raku solution

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

sub MAIN() {
is divide(5,2),   2,  'Divide 5 , 2';
is divide(-5,2), -3,  'Divide -5 , 2';
is divide(-5,-2), 2,  'Divide -5 , -2';
done-testing;
}

sub divide(Int \$M is copy, Int \$N is copy) {
my \$quotient = 0;
my \$negative = 0;

if (\$M < 0 && \$N > 0) {
\$negative = 1;
\$M = - \$M;
} elsif (\$M > 0 && \$N < 0) {
\$negative = 1;
\$N = - \$N;
} elsif (\$M < 0 && \$N < 0) {
\$M = - \$M;
\$N = - \$N;
}

while (\$M > \$N) {
\$M = \$M - \$N;
\$quotient++;
}

return (\$negative) ??
- \$quotient - 1 !! \$quotient;
}
``````

Output perl6 ch-1.p6

``````ok 1 - Divide 5 , 2
ok 2 - Divide -5 , 2
ok 3 - Divide -5 , -2
1..3``````

## TASK #2 › Power Integers

You are given an integer `\$N`.

Write a script to check if the given number can be expressed as mn where `m` and `n` are positive integers. Otherwise print 0.

#### Example 1:

For given \$N = 9, it should print 32 or `3^2`.

#### Example 2:

For given \$N = 45, it should print 0.

For this challenge I just brute forced to solution looking for all possible exponentials for \$i ^ \$j where (2 < i, j < \$N) .

#### Perl 5 solution

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

is (powers(9),   '3^2',      'Power: 9');
is (powers(16),  '2^4, 4^2', 'Power: 16');
is (powers(45),  '0',        'Power: 45');
done_testing();

sub powers {
my (\$N) = @_;

for my \$i (2 .. \$N) {
for my \$j (2 .. \$N) {
if (\$i ** \$j > \$N) {
last;
} elsif (\$i ** \$j == \$N) {
push @answers, \$i . '^' . \$j;
}
}
}

join ', ', @answers : 0;
}
``````

Output ./ch-2.pl

``````ok 1 - Power: 9
ok 2 - Power: 16
ok 3 - Power: 45
1..3``````

#### Raku solution

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

sub MAIN() {
is powers(9),   '3^2',      'Power: 9';
is powers(16),  '2^4, 4^2', 'Power: 16';
is powers(45),  '0',        'Power: 45';
done-testing;
}

sub powers(Int \$N) {

for (2 .. \$N) -> \$i {
for (2 .. \$N) -> \$j {
if (\$i ** \$j > \$N) {
last;
} elsif (\$i ** \$j == \$N) {
}
}
}

}
``````

Output perl6 ch-2.p6

``````ok 1 - Power: 9
ok 2 - Power: 16
ok 3 - Power: 45
1..3``````

# PERL WEEKLY CHALLENGE – 065

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

## TASK #1 › Digits Sum

##### Reviewed by:Ryan Thompson

You are given two positive numbers `\$N` and `\$S`.

Write a script to list all positive numbers having exactly `\$N` digits where sum of all digits equals to `\$S`.

## Example

```Input:
\$N = 2
\$S = 4

Output:
13, 22, 31, 40
```

For this challenge, i just brute forced by iterating through all N digit numbers.

#### Perl 5 solution

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

# Default \$N and \$S
my \$N = shift // 2;
my \$S = shift // 4;

# Calculate start and end
my \$start = 10 ** (\$N - 1);
my \$end   = (10 ** \$N) - 1;

# Process each number
for my \$i (\$start .. \$end) {
my @numbers = split(//, \$i);
if (sum(@numbers) == \$S);
}

``````

Output: perl ./ch-1.pl

``13, 22, 31, 40``

#### Raku solution

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

multi MAIN(Int \$N, Int \$S) {

# Calculate start and end
my \$start = 10 ** (\$N - 1);
my \$end   = (10 ** \$N) - 1;

# Process each number
for (\$start .. \$end) -> \$i {
my @numbers = \$i.comb;
if (@numbers.sum == \$S);
}

}
``````

Output perl6 ch-1.p6

``13, 22, 31, 40``

## TASK #2 › Palindrome Partition

##### Reviewed by:Ryan Thompson

You are given a string `\$S`. Write a script print all possible partitions that gives Palindrome. Return -1 if none found.

Please make sure, partition should not overlap. For example, for given string “abaab”, the partition “aba” and “baab” would not be valid, since they overlap.

## Example 1

```Input: \$S = 'aabaab'
Ouput: 'aa', 'baab'

```

## Example 2

```Input: \$S = 'abbaba'
Output:
There are 2 possible solutions.
a) 'abba'
b) 'bb', 'aba'
```

For this challenge I broke the work down into separate letters and just iterated through the letters. Then I used a little recursion to break the palindrome down into chunks to print all possible answers.

#### Perl 5 solution

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

say 'Solutions for: aabaab:';
};

say "\n\nSolutions for: abbaba:";
};

sub palindrome {
my \$string = shift;
my @letters = split (//, \$string);

# Divide the answers into chunks #scalar(@letters)
for (my \$i = 0; \$i < scalar(@letters); \$i++) {
my \$possible_word = '';

# Process each chunk
for (my \$j = \$i; \$j < scalar(@letters); \$j++) {
\$possible_word .= \$letters[\$j];

# Make sure the word is longer than 1 char
if (length(\$possible_word) > 1) {
# Check this word
if (\$possible_word eq reverse(\$possible_word)) {
# Recusive check
my \$sub_string = substr(\$string, \$j + 1);
my @palins = palindrome(\$sub_string);

if (scalar (@palins)) {
for my \$palin (@palins) {
push @answers, [ \$possible_word, @\$palin ] ;
}
} else {
}
}
}
}
}

}
``````

Output ./ch-2.pl

``````Solutions for: aabaab:
aa, baab
aa, aa
aabaa
aba
baab
aa

Solutions for: abbaba:
abba
bb, aba
bab
aba``````

#### Raku solution

``````# Test: perl6 ch-2.p6
sub MAIN() {
say 'Solutions for: aabaab:';
};

say "\n\nSolutions for: abbaba:";
};
}

sub palindrome (Str \$string){
my @letters = \$string.comb;

# Divide the answers into chunks #scalar(@letters)
loop (my \$i = 0; \$i < @letters.elems; \$i++) {
my \$possible_word = '';

# Process each chunk
loop (my \$j = \$i; \$j < @letters.elems; \$j++) {
\$possible_word ~= @letters[\$j];

# Make sure the word is longer than 1 char
if (\$possible_word.chars > 1) {

# Check this word
if (\$possible_word eq \$possible_word.flip) {
# Recusive check
my \$sub_string = substr(\$string, \$j + 1);
my @palins = palindrome(\$sub_string);

if (@palins) {
for (@palins) -> \$palin {
push @answers, [ \$possible_word, @\$palin ] ;
}
} else {
}
}
}
}
}
}
``````

Output perl6 ch-2.p6

``````Solutions for: aabaab:
aa, baab
aa, aa
aabaa
aba
baab
aa

Solutions for: abbaba:
abba
bb, aba
bab
aba``````

# PERL WEEKLY CHALLENGE – 064

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

## TASK #1 › Minimum Sum Path

##### Reviewed by:Ryan Thompson

Given an m × n matrix with non-negative integers, write a script to find a path from top left to bottom right which minimizes the sum of all numbers along its path. You can only move either down or right at any point in time.

## Example

Input:

```[ 1 2 3 ]
[ 4 5 6 ]
[ 7 8 9 ]

```

The minimum sum path looks like this:

```1→2→3
↓
6
↓
9

```

Thus, your script could output: 21 ( 1 → 2 → 3 → 6 → 9 )

For this challenge I just used a recursive algorithm to either branch right or down, storing the path and totals. The difficult path of this challenge was keeping the path in memory and storing the minimum path.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-1.pl
use strict;
use warnings;
use feature qw /say/;

my @path;
my \$matrix = [
[ 1, 2, 3 ],
[ 4, 5, 6 ],
[ 7, 8, 9 ],
];

say min_path(\$matrix, 0, 0, \@path)
. ": " . (join ' → ', @path);

# Calculate the max path
sub min_path {
my (\$matrix, \$m, \$n, \$path) = @_;

# Size of matrix
my \$max_m = scalar(@{\$matrix->});
my \$max_n = scalar(@{\$matrix});

# Out of bounds
return undef
if (\$m >= \$max_m || \$n >= \$max_n);

# Points in the branch
my \$total = \$matrix->[\$m][\$n];

# Calculate path
push @\$path, \$total;
my @path1 = map { \$_ } @\$path;
my @path2 = map { \$_ } @\$path;

# Points produced by each branch
my \$score1 = min_path(\$matrix, \$m + 1, \$n, \@path1);
my \$score2 = min_path(\$matrix, \$m, \$n + 1, \@path2);

# Return the better branch
if ( (\$score1 && \$score2 && \$score1 <= \$score2) ||
(\$score1 && !\$score2) ) {
@\$path = map { \$_ } @path1;
return \$total + \$score1;
} elsif ( (\$score1 && \$score2 && \$score1 > \$score2) ||
(!\$score1 && \$score2) ) {
@\$path = map { \$_ } @path2;
return \$total + \$score2;
} else {
return \$total;
}
}
``````

Output: perl ./ch-1.pl

``21: 1 → 2 → 3 → 6 → 9``

#### Raku solution

``````# Test: perl6 ch-1.p6
sub MAIN() {
my @path;
my @matrix = [
[ 1, 2, 3 ],
[ 4, 5, 6 ],
[ 7, 8, 9 ],
];

say min-path(@matrix, 0, 0, @path)
~ ': ' ~ @path.join(" → ");
}

# Calculate the max path
sub min-path(@matrix, Int \$m, Int \$n, @path) {

# Size of matrix
my \$max_m = @matrix.elems;
my \$max_n = @matrix.elems;

# Out of bounds
return Nil
if (\$m >= \$max_m || \$n >= \$max_n);

# Points in the branch
my \$total = @matrix[\$m][\$n];

# Calculate path
@path.push(\$total);
my @path1 = @path.map({ \$_ });
my @path2 = @path.map({ \$_ });

# Points produced by each branch
my \$score1 = min-path(@matrix, \$m + 1, \$n, @path1);
my \$score2 = min-path(@matrix, \$m, \$n + 1, @path2);

# Return the better branch
if ( (\$score1 && \$score2 && \$score1 <= \$score2) ||
(\$score1 && !\$score2) ) {
@path = @path1.map({ \$_ });
return \$total + \$score1;
} elsif ( (\$score1 && \$score2 && \$score1 > \$score2) ||
(!\$score1 && \$score2) ) {
@path = @path2.map({ \$_ });
return \$total + \$score2;
} else {
return \$total;
}
}
``````

Output perl6 ch-1.p6

``21: 1 → 2 → 3 → 6 → 9``

## TASK #2 › Word Break

You are given a string `\$S` and an array of words `@W`.

Write a script to find out if `\$S` can be split into sequence of one or more words as in the given `@W`.

Print the all the words if found otherwise print 0.

## Example 1:

```Input:

\$S = "perlweeklychallenge"
@W = ("weekly", "challenge", "perl")

Output:

"perl", "weekly", "challenge"

```

## Example 2:

```Input:

\$S = "perlandraku"

Output:

0 as none matching word found.
```

For this challenge I just created a regex string from the words and used the split function (with capturing) to return the words.

#### Perl 5 solution

``````#!/usr/bin/perl
# Test: ./ch-2.pl
use strict;
use warnings;
use feature qw /say/;

my \$S = "perlweeklychallenge";
my @W = ("weekly", "challenge", "perl");
say \$S;
say check_word(\$S, \@W);

my \$S2 = "perlandraku";
my @W2 = ("python", "ruby", "haskell");
say "\n" . \$S2;
say check_word(\$S2, \@W2);

sub check_word {
my (\$string, \$words) = @_;

my \$word_re = join '|', @\$words;
my @split_words =
grep { \$_  }
split (/(\$word_re)/, \$string);

return scalar(@split_words) == scalar(@\$words) ?
join ' ', @split_words : 0;
}
``````

Output ./ch-2.pl

``````perlweeklychallenge
weekly challenge perl

perlandraku
0``````

#### Raku solution

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

sub MAIN() {
my \$S = "perlweeklychallenge";
my @W = ("weekly", "challenge", "perl");
say \$S;
say check-word(\$S, @W);

my \$S2 = "perlandraku";
my @W2 = ("python", "ruby", "haskell");
say "\n" ~ \$S2;
say check-word(\$S2, @W2);
}

sub check-word(Str \$string, @words) {
my @split_words =
\$string.split(/<@words>/, :v, :skip-empty);

return (@split_words.elems == @words.elems) ??
@split_words.join(" ") !! 0;
}
``````

Output perl6 ch-2.p6

``````perlweeklychallenge
perl weekly challenge

perlandraku
0``````