PERL WEEKLY CHALLENGE – 057

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


TASK #1 › Invert Tree


You are given a full binary tree of any height, similar to the one below:

Write a script to invert the tree, by mirroring the children of every node, from left to right. The expected output from the tree above would be:

The input can be any sensible machine-readable binary tree format of your choosing, and the output should be the same format.

BONUS

In addition to the above, you may wish to pretty-print your binary tree in a human readable text-based format similar to the following:

       1
      /  \
     3    2
    / \  / \
   7   6 5  4


For this challenge I used perl 5’s object oriented framework https://metacpan.org/pod/Mouse to create the Binary Tree. (Similar to last weeks challenge)

For Raku I used the Native Class Class

After creating the Binary Tree is was just a matter of populating it.

To populate it I just passed the data in a structure like what is shown below. Basically a list with 2 items. The first item is the value of the node and the second item of the list is an array ref containing two lists corresponding to the left and right branches.

my $btree_data = [
	1 => [
		[ 2 => [4 , 5] ],
		[ 3 => [6 , 7] ],
	]
];


Or in Raku

my $btree_data = [
	1 , [
		[ 2 , [4 , 5] ],
		[ 3 , [6 , 7] ],
	]
];


I didn’t bother with the Bonus formatted list as I didn’t really have the time this week.

Perl 5 solution

#!/usr/bin/perl
# Test: ./ch-1.pl 4
package BTree::Node; # Binary Tree

use strict;
use warnings;
use Mouse;

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

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

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

__PACKAGE__->meta->make_immutable();

package BTree; # Binary Tree

use strict;
use warnings;
use Mouse;
use feature qw /say/;

has 'root' => (
	is  => 'rw',
	isa => 'BTree::Node',
	default => sub { BTree::Node->new() }
);

# Creates the Binary tree from the data
sub create_btree {
	my ($self, $data, $node) = @_;

	$node = $self->root
		unless($node);

	# End of the line
	if (ref $data ne 'ARRAY') {
		$node->value($data);
		return;
	}

	# Value is contained in the first item of the list
	$node->value($data->[0]);

	# Left branch
	if ($data->[1]->[0]) {
		$node->left( BTree::Node->new() );
		$self->create_btree($data->[1]->[0], $node->left );
	}

	# Right branch
	if ($data->[1]->[1]) {
		$node->right( BTree::Node->new() );
		$self->create_btree($data->[1]->[1], $node->right );
	}
}

# Print the tree
sub print_tree {
	my ($self, $node) = @_;

	$node = $self->root
		unless($node);

	my $left = ($node->left) ?
		$self->print_tree($node->left) :
		undef;

	my $right = ($node->right) ?
		$self->print_tree($node->right) :
		undef;

	my $lists = ($left || $right) ?
		          ' => ' . "[ $left, $right ]" :
		          '';

	return $node->value . $lists;
}

# Invert the tree
sub invert_tree {
	my ($self, $node) = @_;

	$node = $self->root
		unless($node);

	# Branch left
	$self->invert_tree( $node->left )
		if ($node->left);

	# Branch right
	$self->invert_tree( $node->right )
		if ($node->right);

	# Invert the tree
	my $temp = $node->left;
	$node->left($node->right);
	$node->right($temp);

}

__PACKAGE__->meta->make_immutable();

package main;

use strict;
use warnings;
use feature qw /say/;

my $btree_data = [
	1 => [
		[ 2 => [4 , 5] ],
		[ 3 => [6 , 7] ],
	]
];
my $btree = BTree->new();
my $node = $btree->root;

$btree->create_btree($btree_data);
say "Original: " . $btree->print_tree();
$btree->invert_tree();
say "Inverted: " . $btree->print_tree();

Output

Original: 1 => [ 2 => [ 4, 5 ], 3 => [ 6, 7 ] ]
Inverted: 1 => [ 3 => [ 7, 6 ], 2 => [ 5, 4 ] ]

Raku solution

# Test: perl6 ch-2.p6
class BTree {

	my class Node {
		has Int $.value is rw;
		has Node $.left is rw;
		has Node $.right is rw;
	};

	has Node $.root is rw;

	# Create the binary trees
	multi method create-btree($data) {
		self.root = Node.new;
		self.create-btree($data, self.root)
	}

	multi method create-btree($data, Node $node) {
		$node.value = $data.[0];

		# Left branch
		if ($data.[1].[0]) {
			$node.left = Node.new();
			self.create-btree($data.[1].[0], $node.left);
		}

		# Right branch
		if ($data.[1].[1]) {
			$node.right = Node.new();
			self.create-btree($data.[1].[1], $node.right);
		}
	}

	# Print the tree
	multi method print-tree() {
		self.print-tree(self.root);
	}

	multi method print-tree(Node $node) {
		my $left = ($node.left) ??
			self.print-tree($node.left) !!
			Nil;

		my $right = ($node.right) ??
			self.print-tree($node.right) !!
			Nil;

		my $lists = ($left || $right) ??
		            ' => ' ~ "[ $left, $right ]" !!
		            '';

		return $node.value ~ $lists;
	}

	# Invert the tree
	multi method invert-tree() {
		self.invert-tree(self.root);
	}

	multi method invert-tree(Node $node) {
		# Branch left
		self.invert-tree( $node.left )
			if ($node.left);

		# Branch right
		self.invert-tree( $node.right )
			if ($node.right);

		# Invert
		my $temp = $node.left;
		$node.left = $node.right;
		$node.right = $temp;
	}
}

# Main program
sub MAIN() {
	my $btree_data = [
		1 , [
			[ 2 , [4 , 5] ],
			[ 3 , [6 , 7] ],
		]
	];
	my $btree = BTree.new();
	$btree.create-btree($btree_data);
	say 'Original: ' ~  $btree.print-tree;
	$btree.invert-tree();
	say 'Inverted: ' ~ $btree.print-tree;
}

Output

Original: 1 => [ 2 => [ 4, 5 ], 3 => [ 6, 7 ] ]
Inverted: 1 => [ 3 => [ 7, 6 ], 2 => [ 5, 4 ] ]

TASK #2 › Shortest Unique Prefix


Write a script to find the shortest unique prefix for each each word in the given list. The prefixes will not necessarily be of the same length.

Sample Input

    [ "alphabet", "book", "carpet", "cadmium", "cadeau", "alpine" ]

Expected Output

    [ "alph", "b", "car", "cadm", "cade", "alpi" ]

For this challenge I decided to use a data structure known as a Trie (https://en.wikipedia.org/wiki/Trie).

I used the module: https://metacpan.org/pod/Tree::Trie in perl 5 to create the structure and just found the prefixes using the lookup method iterating over each letter of the word until I found just 1 word with the prefix. The code probably explains it better than I can.

In Raku I used the https://modules.raku.org/dist/Concurrent::Trie:cpan:JNTHN module.

This was my first time ever using a Raku module, so it was interesting for me to use zef. The Raku code is similar to the perl code exempt the lookup method was called $trie->lookup.


Perl 5 solution

#!/usr/bin/perl
# Test: ./ch-2.pl

use strict;
use warnings;
use feature qw /say/;
use Tree::Trie;

my @words = qw[
	alphabet  book    carpet
	cadmium   cadeau  alpine
];
my $trie = Tree::Trie->new;
$trie->add(@words);

# Find each answer
my @answers;
for my $word (@words) {
	my @letters = split('', $word);
	my $search_word = '';

	for my $letter (@letters) {
		$search_word .= $letter;
		my @counts = $trie->lookup($search_word);

		# If there is only one word left,
		# we are unique
		if (scalar(@counts) == 1) {
			push @answers, $search_word;
			last;
		}
	}
}

say join ', ', @answers;

Output

alph, b, car, cadm, cade, alpi

Raku solution

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

sub MAIN() {
	my $trie = Concurrent::Trie.new;
	my @words = qw[
		alphabet  book    carpet
		cadmium   cadeau  alpine
	];

	# Insert each word
	for (@words) -> $word {
		$trie.insert($word)
	}

	# Find each answer
	my @answers;
	for (@words) -> $word {
		my $search_word = '';

		for ($word.comb) -> $letter {
			$search_word ~= $letter;
			my @counts = $trie.entries($search_word);

			# If there is only one word left,
			# we are unique
			if (@counts.elems == 1) {
				@answers.push($search_word);
				last;
			}
		}
	}

	say @answers.perl;
}

Output

["alph", "b", "car", "cadm", "cade", "alpi"]

One thought on “PERL WEEKLY CHALLENGE – 057

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