PERL WEEKLY CHALLENGE – 062

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


TASK #1 › Sort Email Addresses

Submitted by: Neil Bowers
Reviewed by: Ryan Thompson

Write a script that takes a list of email addresses (one per line) and sorts them first by the domain part of the email address, and then by the part to the left of the @ (known as the mailbox).

Note that the domain is case-insensitive, while the mailbox part is case sensitive. (Some email providers choose to ignore case, but that’s another matter entirely.)

If your script is invoked with arguments, it should treat them as file names and read them in order, otherwise your script should read email addresses from standard input.

Bonus

Add a -u option which only includes unique email addresses in the output, just like sort -u.

Example

If given the following list:

name@example.org
rjt@cpan.org
Name@example.org
rjt@CPAN.org
user@alpha.example.org

Your script (without -u) would return:

user@alpha.example.org
rjt@cpan.org
rjt@CPAN.org
Name@example.org
name@example.org

With -u, the script would return:

user@alpha.example.org
rjt@CPAN.org
Name@example.org
name@example.org

For this challenge I just used the native grep and sort functions after splitting the username and domain name from the email.

Perl 5 solution

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

# Unique flag
my $unique;
GetOptions ("unique"  => \$unique);

# Hash to store unique emails
my %unique_emails;

# Data
my @data = qw /
	name@example.org
	rjt@cpan.org
	Name@example.org
	rjt@CPAN.org
	user@alpha.example.org
/;

my @sorted_data = sort by_domain @data;
@sorted_data = grep { make_unique($_) } @sorted_data
	if ($unique);
say join "\n", @sorted_data;

# Check if the email is unique
sub make_unique {
	my $email = shift;
	my ($user, $domain) = split_email($email);
	my $unique_email = $user . '@' . lc($domain);

	return 0
		if ($unique_emails{$unique_email});

	$unique_emails{$unique_email} = 1;
	return 1;
}

# Sort by domain function
sub by_domain {
	my ($user_a, $domain_a) = split ('\@', $::a);
	my ($user_b, $domain_b) = split ('\@', $::b);
	lc($domain_a) cmp lc($domain_b) or
	$user_a       cmp $user_b;
}

# Split email into username and domain
sub split_email {
	return split ('\@', shift);
}

Output: perl ./ch-1.pl – u

user@alpha.example.org
rjt@cpan.org
Name@example.org
name@example.org

Raku solution

# Test: perl6 ch-1.p6 -u
use Getopt::Long;
get-options("u" => my $unique);

# Hash to store unique emails
my %unique_emails;

sub MAIN() {
	# Data
	my @data = qw /
		name@example.org
		rjt@cpan.org
		Name@example.org
		rjt@CPAN.org
		user@alpha.example.org
	/;

	my @sorted_data = @data.sort(&by-domain);
	@sorted_data = @sorted_data.grep(&make-unique)
		if ($unique);

	say @sorted_data.join("\n");
}

# Check if the email is unique
sub make-unique(Str $email)  {
	my ($user, $domain) = split-email($email);
	my $unique_email = $user ~ '@' ~ $domain.lc;

	return False
		if (%unique_emails{$unique_email});

	%unique_emails{$unique_email} = 1;
	return True;
}

# Sort by domain function
sub by-domain {
	my ($user_a, $domain_a) = split-email($^a);
	my ($user_b, $domain_b) = split-email($^b);
	$domain_a.lc cmp $domain_b.lc or
	$user_a      cmp $user_b;
}

# Split email into username and domain
sub split-email(Str $email) {
	return $email.split('@');
}

Output perl6 ch-1.p6 -u

user@alpha.example.org
rjt@cpan.org
Name@example.org
name@example.org

TASK #2 › N Queens

Submitted by: Ryan Thompson

A standard 8×8 chessboard has 64 squares. The Queen is a chesspiece that can attack in 8 directions, as shown by the green shaded squares below:

It is possible to place 8 queens on to a single chessboard such that none of the queens can attack each other (i.e., their shaded squares would not overlap). In fact, there are multiple ways to do so, and this is a favourite undergraduate assignment in computer science.

But here at PWC, we’re going to take it into the next dimension!

Your job is to write a script to work with a three dimensional chess cube, M×M×M in size, and find a solution that maximizes the number of queens that can be placed in that cube without attacking each other. Output one possible solution.

Example

A trivial 2×2×2 solution might look like this (1 = queen, 0 = empty):

[
    [[1,0],     # Layer 1
     [0,0]],

    [[0,0],     # Layer 2
     [0,0]],
]

This problem was quite interesting. I just used a computer science principle known as Backtracking (https://en.wikipedia.org/wiki/Backtracking) to brute force the answer.

This method is computationally very expensive, and there are some ways to increase efficiency which I haven’t really implemented (for example marking squares as invalid) or implementing symmetry optimizations.

I solved this problem by first creating a 2 dimensional solution to the nqueens problem and expanded it to the third dimension. This is why you’ll see inconsistencies in the code like.

for 0 .. $k
for 0 .. $i
for 0 .. $j

Basically I placed a queen on a column, then another queen on the next column if it’s a valid move, if no valid moves are found, it would move 1 column back and try to place the queen on another row in that column. We do this until we find a solution or the exhaust the search.

Edit: Also decided to codepen some solutions:
8x8x8 solutions:
https://codepen.io/orangerascal/pen/ExVBdLE

and all solutions to 8×8:
https://codepen.io/orangerascal/pen/qBOzMzV

Edi: Fixed a few bugs

Perl 5 solution

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

# Size of board
my $size = $ARGV[0] || 3;

# Store best solution
our $bs_board       = init_board( $size );
our $bs_queen_count = 0;

# Our Playing board
my $board = init_board( $size );
if (nqueens($board, 0, 0, 0)) {
	say "Real Solution:\n";
	say display_board($board);
} else {
	say "Best Solution:\n";
	say display_board($bs_board);
}

# Nqueens algorithm
sub nqueens {
	my ($board, $next_z, $next_col, $placed) = @_;
	my $size = scalar(@$board);
	my $index = $next_z * $size + $next_col;

	# We found a solution
	return 1
		if $index > ($size * $size) - 1 ;

	# We've moved to the next level
	if ($next_col > $size - 1) {
		$next_z++;
		$next_col -= $size;
	};

	# Backtrack till we find a solution
	for my $row (0 .. $size) {
		# We need this to solve best solution
		if ($row == $size && $next_col + 1 < ($size * $size) - 1 ) {
			nqueens($board, $next_z, $next_col + 1, $placed);
		}

		if ($row != $size && valid_placement($board, $size, $next_z, $row, $next_col)) {
			$board->[$next_z]->[$row]->[$next_col] = 1;

			# Queen placed
			$placed++;

			# Current best solution
			if ($bs_queen_count < $placed) {
				copy_board($board, $bs_board);
				$bs_queen_count = $placed;
			}

			# Solution found
			return 1
				if (nqueens($board, $next_z, $next_col + 1, $placed));

			# Backtrack
			$placed--;
			$board->[$next_z]->[$row]->[$next_col] = 0;
		}
	}

	# If we get here there is no
	# possible solution to this chain
	return 0;
}

# Check valid placements
sub valid_placement {
	my ($board, $size, $height, $row, $col) = @_;

	# Check rows/cols
	for (my $i = 0; $i < $size; $i++) {
		return 0
			if (
				$board->[$height]->[$row]->[$i] ||
				$board->[$height]->[$i]->[$col]
			);
	}

	# Check 2d upper left diagonals
	my $offset = $size - $col - 1;
	my $i = $row + $offset; my $j = $col + $offset;
	while ($i >= 0 && $j >= 0) {
		if ($i >= 0 && $j >= 0 && $i < $size && $j < $size) {
			return 0
				if ($board->[$height]->[$i]->[$j]);
		}
		$i--; $j--;
	}

	# Check 2d lower right
	$i = $row - $offset; $j = $col + $offset;
	while ($i <= $size && $j >= 0) {
		return 0
			if ($board->[$height]->[$i]->[$j]);
		$i++; $j--;
	}

	# Check lower z and diags
	for (my $k = $size - 1; $k >= 0; $k--) {
		my $range = $height - $k;
		$range = -$range if ($range < 0);

		for my $i (-$range, 0, $range) {
			for my $j (-$range, 0, $range) {
				my $a = $row + $i ;
				my $b = $col + $j;

				# Out of bound;
				next if ($a < 0 || $b < 0);
				next if ($a >= $size || $b >= $size);

				return 0
					if ($board->[$k]->[$a]->[$b]);

				return 0
					if ($board->[$k]->[$a]->[$b]);
			}
		}
	}


	# Return true if we don't
	# collide with another queen
	return 1;
}

# Initializes the board
sub init_board {
	my $size = (shift) - 1;
	my @board;

	for my $i (0 .. $size) {
		for my $j (0 .. $size) {
			for my $k (0 .. $size) {
				$board[$i][$j][$k] = 0;
			}
		}
	}

	return \@board;
}

# Displays the board
sub display_board {
	my $board = shift;
	my $size = scalar (@$board);

	# Store the board string into $b
	my $b;
	for my $k (0 .. $size - 1) {
		$b .= "z = $k\n";
		$b .= '|' . '-' x (4 * $size - 1) . '|' . "\n";
		for my $i (0 .. $size - 1) {
			$b .= '|';
			for my $j (0 .. $size - 1) {
				my $space = ($board->[$k]->[$i]->[$j] == 1) ?
				            '*' : ' ';
				$b .= " $space |"
			}
			$b .= "\n";
		}
		$b .= '|' . '-' x (4 * $size - 1) . '|' . "\n\n";
	}

	# Return the board representation
	return $b;
}

# Copy board
sub copy_board {
	my ($src, $copy) = @_;
	my $size = scalar(@$src) - 1;

	for my $i (0 .. $size) {
		for my $j (0 .. $size) {
			for my $k (0 .. $size) {
				$copy->[$i]->[$j]->[$k] =
					$src->[$i]->[$j]->[$k];
			}
		}
	}
}

Output ./ch-2.pl 2

Best Solution:

z = 0
|-----------|
| * |   |   |
|   |   |   |
|   | * |   |
|-----------|

z = 1
|-----------|
|   |   | * |
|   |   |   |
|   |   |   |
|-----------|

z = 2
|-----------|
|   |   |   |
| * |   |   |
|   |   |   |
|-----------|

Raku solution

# Test: perl6 ch-2.p6
# Store best solution
our @bs_board;
our $bs_queen_count = 0;

multi MAIN() {
	MAIN(3);
}

multi MAIN(Int $size) {
	@bs_board = init-board( $size );

	# Our Playing board
	my @board = init-board( $size );
	if (nqueens(@board, 0, 0, 0)) {
		say "Real Solution:\n";
		say display-board(@board);
	} else {
		say "Best Solution:\n";
		say display-board(@bs_board);
	}
}

# Nqueens algorithm
sub nqueens(@board, Int $next_z is copy, Int $next_col is copy, Int $placed is copy) {
	my $size = @board.elems;
	my $index = $next_z * $size + $next_col;

	# We found a solution
	return True
		if $index > ($size * $size) - 1 ;

	# We've moved to the next level
	if ($next_col > $size - 1) {
		$next_z++;
		$next_col -= $size;
	};

	# Backtrack till we find a solution
	for (0 .. $size) -> $row {
		# We need this to solve best solution
		if ($row == $size && $next_col + 1 < ($size * $size) - 1) {
			nqueens(@board, $next_z, $next_col + 1, $placed);
		}

		if ($row != $size && valid-placement(@board, $size, $next_z, $row, $next_col)) {
			@board[$next_z][$row][$next_col] = 1;

			# Queen placed
			$placed++;

			# Current best solution
			if ($bs_queen_count < $placed) {
				copy-board(@board, @bs_board);
				$bs_queen_count = $placed;
			}

			# Solution found
			return True
				if (nqueens(@board, $next_z, $next_col + 1, $placed));

			# Backtrack
			$placed--;
			@board[$next_z][$row][$next_col] = 0;
		}
	}

	# If we get here there is no
	# possible solution to this chain
	return False;
}

# Check valid placements
sub valid-placement(@board, Int $size, Int $height, Int $row, Int $col) {
	my ($i, $j, $k);

	# Check rows
	loop ($i = 0; $i < $size; $i++) {
		return False
			if (@board[$height][$row][$i] ||
			   (@board[$height][$row][$i])
			);
	}

	# Check 2d upper left diagonals
	my $offset = $size - $col - 1;
	$i = $row + $offset; $j = $col + $offset;
	while ($i >= 0 && $j >= 0) {
		return False
			if (@board[$height][$i][$j]);
		$i--; $j--;
	}

	# Check 2d lower right
	$i = $row - $offset; $j = $col + $offset;
	while ($i <= $size && $j >= 0) {
		if ($i >= 0 && $j >= 0 && $i < $size && $j < $size) {
			return False
				if (@board[$height][$i][$j]);
		}
		$i++; $j--;
	}

	# Check lower z
	loop ($k = $size - 1; $k >= 0; $k--) {
		my $range = $height - $k;
		$range = -$range if ($range < 0);

		for (-$range, 0, $range) -> $i {
			for (-$range, 0, $range) -> $j {
				my $a = $row + $i;
				my $b = $col + $j;

				# Out of bound;
				next if ($a < 0 || $b < 0);
				next if ($a >= $size || $b >= $size);

				return False
					if (@board[$k][$a][$b]);
			}
		}
	}

	# Return true if we don't
	# collide with another queen
	return True;
}


# Initializes the board
sub init-board(Int $size) {
	my @board;

	for (0 .. $size - 1) -> $i {
		for (0 .. $size - 1) -> $j {
			for (0 .. $size - 1) -> $k {
				@board[$i][$j][$k] = 0;
			}
		}
	}

	return @board;
}

# Dislays the board
sub display-board(@board) {
	my $size = @board.elems;

	# Store the board string into $b
	my $b;
	for (0 .. $size - 1) -> $k {
		$b ~= "z = $k\n";
		$b ~= '|' ~ '-' x (4 * $size - 1) ~ '|' ~ "\n";
		for (0 .. $size - 1) -> $i {
			$b ~= '|';
			for (0 .. $size - 1) -> $j {
				my $space = (@board[$k][$i][$j] == 1) ??
				            '*' !! ' ';
				$b ~= " $space |"
			}
			$b ~= "\n";
		}
		$b ~= '|' ~  '-' x (4 * $size - 1) ~ '|' ~ "\n\n";
	}

	# Return the board representation
	return $b;
}

# Copy board
sub copy-board(@src, @copy) {
	my $size = @src.elems;

	for (0 .. $size - 1) -> $i {
		for (0 .. $size - 1) -> $j {
			for (0 .. $size - 1) -> $k  {
				@copy[$i][$j][$k] =
					@src[$i][$j][$k];
			}
		}
	}
}

Output perl6 ch-2.p6

Best Solution:

z = 0
|-----------|
| * |   |   |
|   |   |   |
|   | * |   |
|-----------|

z = 1
|-----------|
|   |   | * |
|   |   |   |
|   |   |   |
|-----------|

z = 2
|-----------|
|   |   |   |
| * |   |   |
|   |   |   |
|-----------|

One thought on “PERL WEEKLY CHALLENGE – 062

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s