PERL WEEKLY CHALLENGE – 076

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




TASK #1 › Prime Sum

Submitted by: Mohammad S Anwar
Reviewed by: Ryan Thompson

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

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

Example:

Input:
    $N = 9

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

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

Then I just brute forced it.

Perl 5 solution

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

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

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

	if (is_prime($n)) {
		return "$n is already prime";
	}

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

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

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

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

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

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

			$i = 2;
		}

		return $possible;
	}
}

Output: perl ./ch-1.pl 1212

11 + 1201 = 1212

Raku solution

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

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

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

	if ($n.is-prime) {
		return "$n is already prime";
	}

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

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

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

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

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

			$i = 2;
		}

		return $possible;
	}
}

Output perl6 ch-1.p6 1211

11 + 1201 = 1212


TASK #2 › Word Search

Submitted by: Neil Bowers
Reviewed by: Ryan Thompson

Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.

Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.

Search Grid

B I D E M I A T S U C C O R S T
L D E G G I W Q H O D E E H D P
U S E I R U B U T E A S L A G U
N G N I Z I L A I C O S C N U D
T G M I D S T S A R A R E I F G
S R E N M D C H A S I V E E L I
S C S H A E U E B R O A D M T E
H W O V L P E D D L A I U L S S
R Y O N L A S F C S T A O G O T
I G U S S R R U G O V A R Y O C
N R G P A T N A N G I L A M O O
E I H A C E I V I R U S E S E D
S E T S U D T T G A R L I C N H
H V R M X L W I U M S N S O T B
A E A O F I L C H T O D C A E U
Z S C D F E C A A I I R L N R F
A R I I A N Y U T O O O U T P F
R S E C I S N A B O S C N E R A
D R S M P C U U N E L T E S I L

Output

Found 54 words of length 5 or more when checked against the local dictionary. You may or may not get the same result but that is fine.

aimed, align, antes, argos, arose, ashed, blunt, blunts, broad, buries, clove, cloven, constitution, constitutions, croon, depart, departed, enter, filch, garlic, goats, grieve, grieves, hazard, liens, malign, malignant, malls, margo, midst, ought, ovary, parted, patna, pudgiest, quash, quashed, raped, ruses, shrine, shrines, social, socializing, spasm, spasmodic, succor, succors, theorem, theorems, traci, tracie, virus, viruses, wigged


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

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

Perl 5 solution

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

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

my $max_height = scalar @$matrix;
my $max_width  = scalar @{$matrix->[0]};
my @answers;

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

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

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

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

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

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

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

	return @found;
}

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

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

	return \@letter_matrix
}

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

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

Output ./ch-2.pl

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

Raku solution

# Test: perl6 ch-2.p6

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

	my $max_height = @matrix.elems;
	my $max_width  = @matrix.[0].elems;

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

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

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

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

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

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

	return @found;
}


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

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

	return @letter_matrix;
}

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

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

	return %possible_words
}

Output perl6 ch-2.p6

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

PERL WEEKLY CHALLENGE – 075

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



TASK #1 › Coins Sum

Submitted by: Mohammad S Anwar

You are given a set of coins @C, assuming you have infinite amount of each coin in the set.

Write a script to find how many ways you make sum $S using the coins from the set @C.

Example:

Input:
    @C = (1, 2, 4)
    $S = 6

Output: 6
There are 6 possible ways to make sum 6.
a) (1, 1, 1, 1, 1, 1)
b) (1, 1, 1, 1, 2)
c) (1, 1, 2, 2)
d) (1, 1, 4)
e) (2, 2, 2)
f) (2, 4)

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

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

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

Perl 5 solution

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

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

my $total = 0;
my $solutions;

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

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

Output: perl ./ch-1.pl

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

Raku solution

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

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

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

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

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

		@bag.pop;
	}
}

Output perl6 ch-1.p6

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


TASK #2 › Largest Rectangle Histogram

Submitted by: Mohammad S Anwar

You are given an array of positive numbers @A.

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

BONUS: Try to print the histogram as shown in the example, if possible.

Example 1:

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

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

Looking at the above histogram, the largest rectangle (4 x 3) is formed by columns (4, 5, 3 and 7).

Output: 12


Example 2:

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

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

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

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

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


Perl 5 solution

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

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

say "\n";

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

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

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

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

sub largest_rect {
	my @A = @_;

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

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

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

	return $max_area;
}

Output ./ch-2.pl

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


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

Raku solution

# Test: perl6 ch-2.p6

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

	say "\n";

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

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

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

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

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

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

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

	return $max_area;
}

Output perl6 ch-2.p6

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


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

PERL WEEKLY CHALLENGE – 074

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



TASK #1 › Majority Element

Submitted by: Mohammad S Anwar

You are given an array of integers of size $N.

Write a script to find the majority element. If none found then print -1.

Majority element in the list is the one that appears more than floor(size_of_list/2).

Example 1

Input: @A = (1, 2, 2, 3, 2, 4, 2)
Output: 2, as 2 appears 4 times in the list which is more than floor(7/2).

Example 2

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

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

Perl 5 solution

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

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

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

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

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

Output: perl ./ch-1.pl

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

Raku solution

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

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

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

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


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

Output perl6 ch-1.p6

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


TASK #2 › FNR Character

Submitted by: Mohammad S Anwar

You are given a string $S.

Write a script to print the series of first non-repeating character (left -> right) for the given string. Print # if none found.

Example 1

Input: $S = ‘ababc’

Output: ‘abb#c’

Pass 1: “a”, the FNR character is ‘a’
Pass 2: “ab”, the FNR character is ‘b’
Pass 3: “aba”, the FNR character is ‘b’
Pass 4: “abab”, no FNR found, hence ‘#’
Pass 5: “ababc” the FNR character is ‘c’

Example 2

Input: $S = ‘xyzzyx’

Output: ‘xyzyx#’

Pass 1: “x”, the FNR character is “x”
Pass 2: “xy”, the FNR character is “y”
Pass 3: “xyz”, the FNR character is “z”
Pass 4: “xyzz”, the FNR character is “y”
Pass 5: “xyzzy”, the FNR character is “x”
Pass 6: “xyzzyx”, no FNR found, hence ‘#’

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


Perl 5 solution

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

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

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

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

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

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

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

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

		$output .= $fnr;
	}

	return $output
}

Output ./ch-2.pl

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

Raku solution

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

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

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

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

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

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

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

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

		$output ~= $fnr;
	}

	return $output
}

Output perl6 ch-2.p6

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

PERL WEEKLY CHALLENGE – 073

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



TASK #1 › Min Sliding Window

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 42nd 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 41st 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"]