PERL WEEKLY CHALLENGE – 073

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


TASK #1 › Trailing Zeroes

Submitted by: Mohammad S Anwar


TASK #1 › Min Sliding Window

Submitted by: Mohammad S Anwar

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

Input: @A = (1, 5, 0, 2, 9, 3, 7, 6, 4, 8) and $S = 3

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

Submitted by: Mohammad S Anwar

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 1

Input: @A = (7, 8, 3, 12, 10)

Output: (0, 7, 0, 3, 3)

For index 0, the smallest number to the left of $A[0] i.e. 7 is none, so we put 0.
For index 1, the smallest number to the left of $A[1] as compare to 8, in (7) is 7 so we put 7.
For index 2, the smallest number to the left of $A[2] as compare to 3, in (7, 8) is none, so we put 0.
For index 3, the smallest number to the left of $A[3] as compare to 12, in (7, 8, 3) is 3, so we put 3.
For index 4, the smallest number to the left of $A[4] as compare to 10, in (7, 8, 3, 12) is 3, so we put 3 again.

Example 2

Input: @A = (4, 6, 5)

Output: (0, 4, 4)

For index 0, the smallest number to the left of $A[0] is none, so we put 0.
For index 1, the smallest number to the left of $A[1] as compare to 6, in (4) is 4, so we put 4.
For index 2, the smallest number to the left of $A[2] 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

Submitted by: Mohammad S Anwar

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

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

Example 1

Input: $N = 10
Output: 2 as $N! = 3628800 has 2 trailing zeroes

Example 2

Input: $N = 7
Output: 1 as $N! = 5040 has 1 trailing zero

Example 3

Input: $N = 4
Output: 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

Submitted by: Mohammad S Anwar

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

Submitted by: Mohammad S Anwar

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 1

Array: [ 18, 45, 38, 25, 10, 7, 21, 6, 28, 48 ]
Peak: [ 48, 45, 21 ]

Example 2

Array: [ 47, 11, 32, 8, 1, 9, 39, 14, 36, 23 ]
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);

# Store answers
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) {
	# Store answers
	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]

TASK #2 › Trim Linked List

Submitted by: Mohammad S Anwar

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.

NOTE: Please use pure linked list implementation.

Example

Given Linked List: 1 -> 2 -> 3 -> 4 -> 5
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: 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
package LinkedList::Node; # Linked list
use Mouse;

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

has 'next' => (
	is  => 'rw',
	isa => 'Maybe[LinkedList::Node]',
	default => sub {
		return undef
	}
);

__PACKAGE__->meta->make_immutable();

package LinkedList;

use Mouse;
use feature qw /say/;
use LinkedList::Node;

has 'first'  => (
	is  => 'rw',
	isa => 'Maybe[LinkedList::Node]',
	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;
use LinkedList;

# Create lists and remove node
for my $i (1..6) {
	my $ll = LinkedList->new();
	$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
class LinkedList::Node {
	has Int $.value is rw;
	has LinkedList::Node $.next is rw;
}

class LinkedList {
	has LinkedList::Node $.first 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 {
		my $ll = LinkedList.new();
		$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

Submitted by: Mohammad S Anwar

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

Submitted by: Mohammad S Anwar

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

Submitted by: Mohammad S Anwar

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;
my @answers;

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;
		}
	}

	push @answers, $orig
		unless ($i);
}

say join ', ', @answers;

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) {
	my @answers;
	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;
			}

			push @answers, $orig_i
				unless ($i);
		}
	}

	say @answers.join(', ' );
}

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

Submitted by: Mohammad S Anwar

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

Submitted by: Mohammad S Anwar

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->[0]});

	# 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->[0]});

	# 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.[0]) -> $j {
			$m2.[$i][$j] = 1;
		}
	}

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

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

	# Return new matrix
	return $m2;
}

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

	# Process each element of the matrix
	for (^@m) -> $i {
		print '[ ';
		for (^@m.[0]) -> $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.[0]) -> $j {
			$m2.[$i][$j] = 1;
		}
	}

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

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

	# Return new matrix
	return $m2;
}

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

	# Process each element of the matrix
	for (^@m) -> $i {
		print '[ ';
		for (^@m.[0]) -> $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

Submitted by: Mohammad S Anwar

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
package LinkedList::Node; # Linked list
use Mouse;

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

has 'next' => (
	is  => 'rw',
	isa => 'Maybe[LinkedList::Node]',
	default => sub {
		return undef
	}
);

__PACKAGE__->meta->make_immutable();

package LinkedList;

use Mouse;
use feature qw /say/;
use LinkedList::Node;

has 'first'  => (
	is  => 'rw',
	isa => 'Maybe[LinkedList::Node]',
	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;

		# Traverse Linked list
		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;
use LinkedList;

my $ll = LinkedList->new();
$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
class LinkedList::Node {
	has Int $.value is rw;
	has LinkedList::Node $.next is rw;
}

class LinkedList {
	has LinkedList::Node $.first 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;

			# Traverse Linked list
			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() {
	my $ll = LinkedList.new();
	$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

Submitted by: Mohammad S Anwar

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;

# Answers
my @combinations = numeric_combinations($m, $n);
say answer_to_string(\@combinations);

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
sub answer_to_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

Submitted by: Mohammad S Anwar

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

Letter Phone

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'],
};

# Output the answer
say
	'[ "' .
	( join '", "',
		combos($S)
	) .
	'" ]';

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

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

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

			push @answers,
				map { $l . $_}
				@partial_answers;
		} else {
			push @answers, $l;
		}
	}

	return @answers;
}

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) {
	# Output the answer
	say combos($S).perl;
}

# Generate the possible combinations
sub combos(Str $S) {
	my @answers;

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

	for (@(%phone_keys{$letter})) -> $l {
		if ($rest_of_word) {
			my @partial_answers =
				combos($rest_of_word);
			@answers.append(@partial_answers.map({ $l ~ $_ }));
		} else {
			@answers.append($l);
		}
	}

	return @answers;
}

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

Submitted by: Mohammad S Anwar

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

Submitted by: Mohammad S Anwar

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) = @_;
	my @answers;

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

	return scalar(@answers) ?
		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) {
	my @answers;

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

	return @answers.elems ??
		@answers.join(", ") !! 0;
}

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

Submitted by: Mohammad S Anwar
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/;

# Store the answers
my @answers;

# 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);
	push @answers, $i
		if (sum(@numbers) == $S);
}

# Display answers
say join ', ', @answers;

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) {
	# Store the answers
	my @answers;

	# 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;
		@answers.push($i)
			if (@numbers.sum == $S);
	}

	# Display answers
	say @answers.join(", ");
}

Output perl6 ch-1.p6

13, 22, 31, 40

TASK #2 › Palindrome Partition

Submitted by: Mohammad S Anwar
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:';
for my $answer (palindrome('aabaab')) {
	say join ', ', @$answer;
};

say "\n\nSolutions for: abbaba:";
for my $answer (palindrome('abbaba')) {
	say join ', ', @$answer;
};

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

	# All possible answers
	my @answers;

	# 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 {
							push @answers,  [ $possible_word ];
						}
					}
				}
			}
	}

	return @answers;
}

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:';
	for (palindrome('aabaab')) -> $answer {
		say $answer.join(", ")
	};

	say "\n\nSolutions for: abbaba:";
	for (palindrome('abbaba')) -> $answer {
		say $answer.join(", ");
	};
}

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

	# All possible answers
	my @answers;

	# 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 {
							@answers.push([ $possible_word ]);
						}
					}
				}
			}
	}
	return @answers;
}

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

Submitted by: Mohammad S Anwar
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->[0]});
	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[0].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

Submitted by: Mohammad S Anwar

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"
@W = ("python", "ruby", "haskell")

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